#define DBG 0
#define DBG_BINDS 0
#define DBG_MAP_CREATION 0
#define DBG_MAP_LOOKUP 0
#define DBG_ANNOTATIONS 0
#define DBG_MANUAL 0
#define DBG_SEQINJECT_FUNC 0
#define DBG_OMNI 0
#define SILENT 0
#define MENTION_EXCLUDED 0
#define NO_WARN_SITE_MISSING_INSTANCE 0
#define DO_NOT_ELIDE_ANY_OF_THE_INJECTED_TH_SPLICES 1
#define TRY_NO_SEQAIDDISPATCH_INTERMEDIARY 0
#define TRY_SIMPLY_NFDATA 0
#define DRY_RUN 0
#define BYPASS 0
#define EXCLUDE_COLON_MAIN 0
module Seqaid.Core ( seqinjectProgram ) where
import Control.DeepSeq.Bounded ( force )
import GhcPlugins
import Control.Monad
import Data.Generics
import Seqaid.Ann
import Seqaid.Runtime ( SiteID )
import qualified GHC
import qualified FastString as GHC
import qualified RdrName as GHC
import qualified Id as GHC
import qualified RnEnv as GHC
import qualified HscMain as GHC
import qualified Type as GHC
import qualified TyCon as GHC
import qualified TypeRep as GHC
import Data.Maybe
import Data.Dynamic
import Data.Data
import Debug.Trace ( trace )
import System.IO.Unsafe ( unsafePerformIO )
#if 1
import qualified Data.Map as Map
import Data.Map ( Map )
#else
import Prelude hiding ( lookup )
import Data.Map hiding ( null, map, (!), filter )
#endif
import Text.Regex.PCRE
import Data.Array ( (!) )
import Data.Array ( indices )
#if 0
import Text.Regex.PCRE.String
import Text.Regex.Base
import Text.Regex.Base.RegexLike
#endif
import Data.List ( intercalate )
import Data.List ( deleteBy )
import Data.List ( isPrefixOf )
import Data.List ( foldl' )
import Data.List ( nub )
import Data.List ( sort )
import Data.List ( group )
import Data.Char ( isUpper )
import Data.Char ( isLower )
#if ! DEMO_MODE
import Data.Hashable ( hash )
#endif
import Control.Monad.State.Lazy
data CoreBindMeta =
Incl SiteID (Bool,Bool,Bool) CoreBind
| Excl SiteID CoreBind
unMeta :: CoreBindMeta -> CoreBind
unMeta (Incl _ _ b) = b
unMeta (Excl _ b) = b
normalMode = 1 :: Int
preproMode = 2 :: Int
seqinjectProgram :: [String] -> ModGuts -> CoreM ModGuts
seqinjectProgram opts' guts = do
dflags <- getDynFlags
let thismodname = showSDoc dflags $ ppr $ moduleName $ mg_module guts
let opts = reverse opts'
#if DBG
putMsgS $ "plugin opts = " ++ show opts
#endif
let (mode,mode_module)
= let len = length opts in
if 0 == len then (normalMode,"")
else
let modeopt = opts!!0
(modeopt_mode,modeopt_module)
= ( takeWhile (/='=') modeopt
, drop 1 $ dropWhile (/='=') modeopt
)
in
case len of
1 -> case modeopt_mode of
"normal" -> (normalMode,"")
_ -> error "seqinj: incorrect plugin options (error #1)"
3 -> case modeopt_mode of
"prepro" -> (preproMode,modeopt_module)
_ -> error "seqinj: incorrect plugin options (error #2)"
_ -> error "seqinj: incorrect plugin options (error #3)"
if mode == preproMode && mode_module == thismodname
then do
dflags <- getDynFlags
let omni_types_pname = opts!!1
let omni_imports_pname = opts!!2
seqaid_instance_strings <- get_seqaid_instance_strings guts
#if DBG_OMNI
putMsgS $ " XXX seqaid_instance_strings =\n" ++ intercalate "\n" seqaid_instance_strings
#endif
omni_types' <- collectSubexpressionTypes guts
#if DBG_OMNI
let tmp2 = nubsort $ map (sanitiseTypeString . showSDoc dflags . ppr) $ filter (not . isFunTy) omni_types'
putMsgS $ " UUU omni_types =\n" ++ intercalate "\n" tmp2
#endif
let omni_types'' = filter (not . isFunTy) omni_types'
let omni_types''' = filter (not . isForAllTy) omni_types''
let omni_types = filter (not . isDictLikeTy) omni_types'''
let omni_types_strs = map (showSDoc dflags . ppr) omni_types
#if DBG_OMNI
putMsgS $ " VVV omni_types_strs =\n" ++ intercalate "\n" omni_types_strs
#endif
let omni_types_strs_nubbed = nubsort omni_types_strs
let omni_types_strs_nubbed' = map (map (\x -> if x == '\n' then ' ' else x)) omni_types_strs_nubbed
let compactWhite [] = []
compactWhite (' ':' ':t) = compactWhite (' ':t)
compactWhite (h:t) = h:compactWhite t
let omni_types_strs_nubbed'' = map compactWhite omni_types_strs_nubbed'
let omni_types_strs_nubbed''' = filter (\x -> not (null x) && not (isLower (head x))) omni_types_strs_nubbed''
let omni_types_strs_nubbed'''' = omni_types_strs_nubbed'''
let omni_types_strs_nubbed''''' = filter (not . elem '#') omni_types_strs_nubbed''''
let omni_types_strs_nubbed'''''' = filter (instancesAvailable seqaid_instance_strings) omni_types_strs_nubbed'''''
let omni_types_string = intercalate "\n" omni_types_strs_nubbed''''''
#if DBG_OMNI
putMsgS $ " YYY omni_types_string =\n" ++ omni_types_string
#endif
liftIO $ writeFile omni_types_pname omni_types_string
let omni_imports_string' = generateOmniImports dflags omni_types
let omni_imports_string = intercalate "\n" omni_imports_string'
liftIO $ writeFile omni_imports_pname omni_imports_string
return guts
else do
anns <- getAnnotations deserializeWithData guts
:: CoreM (UniqFM [SeqaidAnnIncludeList])
let annseltss = eltsUFM anns :: [[SeqaidAnnIncludeList]]
let annselts_ = concat annseltss :: [SeqaidAnnIncludeList]
let annselts = filter ( \ x -> let SeqaidAnnIncludeList y = x in (not $ null y) && thismodname == takeWhile (/='.') (head y)) annselts_ :: [SeqaidAnnIncludeList]
mananns <- getAnnotations deserializeWithData guts
:: CoreM (UniqFM [SeqaidAnnManual])
let manannseltss = eltsUFM mananns :: [[SeqaidAnnManual]]
let manannselts_ = concat manannseltss :: [SeqaidAnnManual]
let manannselts' = filter ( \ (SeqaidAnnManual y) -> not (elem '.' y) || thismodname /= takeWhile (/='.') y ) manannselts_ :: [SeqaidAnnManual]
let manannselts = map ( \ (SeqaidAnnManual y) -> SeqaidAnnManual (if elem '.' y then y else thismodname++"."++y) ) manannselts' :: [SeqaidAnnManual]
typanns <- getAnnotations deserializeWithData guts
:: CoreM (UniqFM [SeqaidAnnTypes])
let typannseltss = eltsUFM typanns :: [[SeqaidAnnTypes]]
let typannselts = foldl' (\ (SeqaidAnnTypes acclst) (SeqaidAnnTypes lst)->SeqaidAnnTypes (acclst++lst)) (SeqaidAnnTypes []) $ concat typannseltss :: SeqaidAnnTypes
let types = (\ (SeqaidAnnTypes tslst) -> tslst ) typannselts
let dotypes = not $ null types
bianns <- getAnnotations deserializeWithData guts
:: CoreM (UniqFM [SeqaidAnnBindsIncluded])
let biannseltss = eltsUFM bianns :: [[SeqaidAnnBindsIncluded]]
let biannselts_ = concat biannseltss :: [SeqaidAnnBindsIncluded]
let biannselts = map (\ (SeqaidAnnBindsIncluded x) -> SeqaidAnnBindsIncluded $ map (assureFQN thismodname) x) biannselts_ :: [SeqaidAnnBindsIncluded]
#if DBG_ANNOTATIONS
putMsgS $ "annseltss = " ++ concatMap (('\n':) . show) annseltss
putMsgS $ "annselts = " ++ concatMap (('\n':) . show) annselts
putMsgS $ "manannseltss = " ++ concatMap (('\n':) . show) manannseltss
putMsgS $ "manannselts = " ++ concatMap (('\n':) . show) manannseltss
putMsgS $ "typannseltss = " ++ concatMap (('\n':) . show) typannseltss
putMsgS $ "typannselts = " ++ show typannselts
putMsgS $ "biannseltss = " ++ concatMap (('\n':) . show) biannseltss
putMsgS $ "biannselts = " ++ concatMap (('\n':) . show) biannselts
#endif
if null annselts && null manannselts && ( null types || null biannselts )
then do
#if MENTION_EXCLUDED
#if ! SILENT
putMsgS $ "Excluded from seqaid harness: " ++ thismodname
#endif
#endif
return $ guts
else do
#if ! SILENT
#endif
let inclstrs'
= let l = length annselts in
case l of
0 -> []
1 -> let SeqaidAnnIncludeList inlst = head annselts in inlst
_ -> error $ "seqaid: seqaid internal error!\nAt most one SeqaidAnnIncludeList annotation per module (you have " ++ show l ++ ")."
let inclstrs
= inclstrs' ++
let l = length biannselts in
case l of
0 -> []
1 -> let SeqaidAnnBindsIncluded inlst = head biannselts in inlst
_ -> error $ "seqaid: seqaid internal error!\nAt most one SeqaidAnnBindsIncluded annotation per module (you have " ++ show l ++ ")."
let maninclstrs = map ( \ (SeqaidAnnManual manin) -> manin ) manannselts
let binds_ = mg_binds guts
#if DBG
putmess "ppr inclstrs"
putMsgS $ intercalate "\n" inclstrs
putendmess
#endif
#if DBG_BINDS
putmess "ppr binds_"
mapM (prBindWithType dflags) binds_
putendmess
#endif
let names = map (nameOfBind dflags) binds_
let (binds,dbinds,mbinds)
= separateDummyInstanceDecls thismodname names binds_ ([],[],[])
#if DBG_BINDS
putmess "ppr binds"
mapM (printBind dflags) binds
putmess "ppr dbinds"
mapM (printBind dflags) dbinds
putmess "ppr mbinds"
mapM (printBind dflags) mbinds
putendmess
#endif
let (seqinj_noninst_binds, non_seqinj_binds'')
#if NO_TOP_LEVEL_SEQINJ_DUMMIES
= collectSeqinjBinds dflags "$cseqinj" mbinds ([],[])
#else
= collectSeqinjBinds dflags (thismodname++".seqinj") binds ([],[])
#endif
#if DBG_BINDS
putmess "ppr seqinj_noninst_binds"
mapM (printBind dflags) seqinj_noninst_binds
putendmess
putmess "ppr non_seqinj_binds''"
mapM (printBind dflags) non_seqinj_binds''
putendmess
#endif
let (seqinj_inst_binds, non_seqinj_binds')
= collectSeqinjBinds dflags (thismodname++".seqinjinst") non_seqinj_binds'' ([],[])
#if DBG_BINDS
putmess "ppr seqinj_inst_binds"
mapM (printBind dflags) seqinj_inst_binds
putendmess
putmess "ppr non_seqinj_binds'"
mapM (printBind dflags) non_seqinj_binds'
putendmess
#endif
let seqinj_binds = seqinj_inst_binds ++ seqinj_noninst_binds
#if EXCLUDE_COLON_MAIN
let deleteColonMainmain [] bs = error "deleteColonMainmain: unexpected!"
deleteColonMainmain (h:t) bs
| x@(NonRec n e) <- h, (showSDoc dflags $ ppr n) == ":Main.main"
= (reverse bs++t, h)
| otherwise
= deleteColonMainmain t (h:bs)
let (non_seqinj_binds, colon_main_bind)
= deleteColonMainmain non_seqinj_binds' []
#else
let non_seqinj_binds = non_seqinj_binds'
#endif
#if DBG_BINDS
#if 1
putmess "ppr seqinj_noninst_binds"
mapM (printBind dflags) seqinj_noninst_binds
putendmess
#endif
#if 1
putmess "ppr seqinj_inst_binds"
mapM (printBind dflags) seqinj_inst_binds
putendmess
#endif
#if 0
putmess "length seqinj_binds"
putMsgS $ show $ length seqinj_binds
putendmess
#endif
#if 1
putmess "ppr non_seqinj_binds"
mapM (printBind dflags) non_seqinj_binds
putendmess
#endif
#endif
let (non_seqinj_binds_synthetic, non_seqinj_binds_user)
= splitSynthUser dflags non_seqinj_binds ([],[])
#if BYPASS
return $ guts
#else
non_seqinj_binds_meta
<- markNonSeqinjBinds dflags dotypes inclstrs maninclstrs non_seqinj_binds_user [] (1,"",0)
#if DBG_BINDS
putmess "ppr non_seqinj_binds_included"
mapM (printBind dflags) $ map unMeta non_seqinj_binds_meta
putendmess
#endif
let seqinj_map = makeMapSeqinjBinds dflags seqinj_binds
let !_ = force seqinj_map
#if DBG
#if 1
putmess "ppr seqinj_map"
putMsgS $ show $ size seqinj_map
putMsgS $ intercalate "\n" $ map show $ Map.toList seqinj_map
putendmess
#endif
#endif
#if DBG_BINDS
putmess "ppr non_seqinj_binds_meta"
mapM (prMetaBind dflags) non_seqinj_binds_meta
putendmess
#endif
newBinds' <- mapM
(seqinjectFuncPlus seqinj_map seqinj_binds guts types)
non_seqinj_binds_meta
let newBinds''
= non_seqinj_binds_synthetic
#if DO_NOT_ELIDE_ANY_OF_THE_INJECTED_TH_SPLICES
#if ! NO_TOP_LEVEL_SEQINJ_DUMMIES
++ seqinj_binds
#endif
++ mbinds
++ dbinds
#endif
++ newBinds'
#if EXCLUDE_COLON_MAIN
let newBinds = newBinds'' ++ [colon_main_bind]
#else
let newBinds = newBinds''
#endif
#if DBG_BINDS
#if 1
putmess "ppr newBinds"
putMsgS $ showSDoc dflags (ppr newBinds)
putendmess
#endif
#endif
return $ guts { mg_binds = newBinds }
#endif
where
printBind :: DynFlags -> CoreBind -> CoreM CoreBind
printBind dflags bndr@(NonRec b _) = do
putMsgS $ "Non-recursive binding named " ++ showSDoc dflags (ppr b)
return bndr
printBind dflags bndr@(Rec bes) = do
putMsgS $ "Recursive binding named " ++ showSDoc dflags (ppr (fst (head bes)))
return bndr
printBind _ bndr = return bndr
prBind :: DynFlags -> CoreBind -> CoreM ()
prBind dflags bndr@(NonRec b _) = do
putMsgS $ "Non-recursive binding named " ++ showSDoc dflags (ppr b)
prBind dflags bndr@(Rec bes) = do
putMsgS $ "Recursive binding named " ++ showSDoc dflags (ppr (fst (head bes)))
prBind _ bndr = error "prBind: unexpected!"
prBindWithType :: DynFlags -> CoreBind -> CoreM String
prBindWithType dflags bndr = do
let name_part
= case bndr of
NonRec b _ -> "NR " ++ showSDoc dflags (ppr b)
Rec bes -> " R " ++ showSDoc dflags (ppr $ fst $ head bes)
let type_part'' = typeOfBind bndr
let type_part' = showSDoc dflags (ppr type_part'')
let type_part = map (\c->if c == '\n' then ' ' else c) type_part'
let rslt = name_part ++ " :: " ++ type_part
putMsgS rslt
return rslt
prBindWithType _ bndr = error "prBindWithType: unexpected!"
prMetaBind :: DynFlags -> CoreBindMeta -> CoreM ()
prMetaBind dflags inex = do
let (inexstr,sid,dododo,bndr) = case inex of
Incl sid dododo@(do_wrap,do_man,do_typ) bndr -> ("INCL",sid,dododo,bndr)
Excl sid bndr -> ("EXCL",sid,(False,False,False),bndr)
case bndr of
NonRec b _ -> putMsgS $ inexstr ++ " NR name=" ++ showSDoc dflags (ppr b)
++ " sid=" ++ show sid ++ " (do_wrap,do_man,do_typ)=" ++ show dododo
Rec bes -> putMsgS $ inexstr ++ " R name=" ++ showSDoc dflags (ppr (fst (head bes)))
++ " sid=" ++ show sid ++ " (do_wrap,do_man,do_typ)=" ++ show dododo
prMetaBind _ bndr = error "prMetaBind: unexpected!"
splitSynthUser :: DynFlags -> [CoreBind] -> ([CoreBind],[CoreBind]) -> ([CoreBind],[CoreBind])
splitSynthUser dflags [] (ss,us) = (reverse ss,reverse us)
splitSynthUser dflags (h:t) (ss,us)
= case h of
bndr@(NonRec b _) ->
if head (showSDoc dflags (ppr b)) == '$'
then splitSynthUser dflags t (h:ss, us)
else splitSynthUser dflags t ( ss,h:us)
bndr@(Rec bes) ->
if head (showSDoc dflags (ppr bes)) == '$'
then splitSynthUser dflags t (h:ss, us)
else splitSynthUser dflags t ( ss,h:us)
markNonSeqinjBinds :: DynFlags -> Bool -> [String] -> [String] -> [CoreBind] -> [CoreBindMeta] -> SiteID -> CoreM [CoreBindMeta]
markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs [] acc siteid = return $ reverse acc
markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs (h:t) acc siteid
| bndr@(NonRec b _) <- h
= do
let bname = showSDoc dflags (ppr b)
let dododo@(do_wrap, do_man, do_typ)
= ( bname `elem` exorinstrs
, bname `elem` maninclstrs
, dotypes && do_wrap
)
if do_wrap || do_man || do_typ
then
#if DBG
trace ("!i! "++bname) $
#endif
markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Incl siteid dododo h : acc) siteid_next
else
#if DBG
trace ("!x! "++bname) $
#endif
markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Excl siteid h : acc) siteid_next
| bndr@(Rec bes) <- h
= do
let (b,_) = head bes
let bname = showSDoc dflags (ppr b)
let dododo@(do_wrap, do_man, do_typ)
= ( bname `elem` exorinstrs
, bname `elem` maninclstrs
, dotypes && do_wrap
)
if do_wrap || do_man || do_typ
then
#if DBG
trace ("!i! "++bname) $
#endif
markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Incl siteid dododo h : acc) siteid_next
else
#if DBG
trace ("!x! "++bname) $
#endif
markNonSeqinjBinds dflags dotypes exorinstrs maninclstrs t (Excl siteid h : acc) siteid_next
| otherwise = error "markNonSeqinjBinds: unexpected!"
where
(siteid_idx,siteid_name,_) = siteid
#if DEMO_MODE
siteid_hash = 0
#else
siteid_hash = hash (siteid_name++show siteid_idx)
#endif
siteid_next = (1+siteid_idx, siteid_name, siteid_hash)
getBindRHS :: ModGuts -> DynFlags -> CoreBind -> CoreM CoreExpr
getBindRHS guts dflags bind = do
#if DBG
let !_ = trace ( "#$#-bind " ++ (showSDoc dflags $ ppr bind)) $ ()
#endif
let ecb | x@(NonRec b e) <- bind = e
| x@(Rec bes) <- bind = snd $ head bes
| otherwise = trace "BOO!!" $ undefined :: Expr CoreBndr
#if DBG
let !_ = trace ( "#$#-rhs " ++ (showSDoc dflags $ ppr ecb)) $ ()
#endif
return ecb
collectSeqinjBinds :: DynFlags -> String -> [CoreBind] -> ([CoreBind],[CoreBind]) -> ([CoreBind],[CoreBind])
collectSeqinjBinds dflags nam [] acc@(seqinjbs, nonseqinjbs)
=
#if DBG
trace "&&-[]-&&" $
#endif
(seqinjbs, nonseqinjbs)
collectSeqinjBinds dflags nam (h:t) acc@(seqinjbs, nonseqinjbs)
| x@(NonRec n e) <- h
=
#if DBG
trace (" &&-NonRec-&& " ++ (showSDoc dflags $ ppr n)) $
#endif
if (takeWhile (/='_') (showSDoc dflags $ ppr n)) == nam
then recurs True
else recurs False
| x@(Rec nes) <- h
=
let (n,e) = head nes in
#if DBG
trace (" &&-Rec-&& " ++ (showSDoc dflags $ ppr n)) $
#endif
if (takeWhile (/='_') (showSDoc dflags $ ppr n)) == nam
then recurs True
else recurs False
| otherwise = error $ "collectSeqinjBinds: unexpected!"
where
recurs False = collectSeqinjBinds dflags nam t (seqinjbs, h:nonseqinjbs)
recurs True = collectSeqinjBinds dflags nam t (h:seqinjbs, nonseqinjbs)
makeMapSeqinjBinds :: DynFlags -> [CoreBind] -> Map String Int
makeMapSeqinjBinds dflags lst
=
#if DBG_MAP_CREATION
trace ("length lst=" ++ show (length lst) ++ "\n" ++ (intercalate "\n" $ map show $ Map.toList themap2)) $
#endif
themap2
where
themap0 = Map.fromList $ go 0 lst
themap2 = themap0
go i [] = []
go i ((Rec bes):t) = trace ("NonRec: "++sn) $ (se', i) : go (1+i) t
where
(n,e) = head bes
!_ = trace se' $ ()
e_ = gExpandTypeSynonyms e
se_ = showSDoc dflags $ ppr e_
se = sanitiseTypeString se_
marr = (se =~ "Seqaid.Runtime.seqaidDispatch *@ ") :: MatchArray
(a,b) = (marr!0)
se'' = drop (a+b) se
se''' = reverse $ dropWhile (==' ') $ (\(h:t) -> if h == '.' then dropWhile (/=' ') t else (h:t)) $ reverse $ takeWhile (\c->c/='$'&&c/='\n') se''
se' = if head se''' == '(' then se''' else "("++se'''++")"
sn = showSDoc dflags $ ppr n
go i ((h@(NonRec n e)):t) = (se', i) : go (1+i) t
where
#if 0 && DBG
sh = showSDoc dflags $ ppr h
!_ = trace ("\n%%%%%%%%%%%%%%% sh %\n"++sh) $ ()
!_ = trace ("\n%%%%%%%%%%%%%%% sn %\n"++sn) $ ()
!_ = trace ("\n%%%%%%%%%%%%%%% se %\n"++se) $ ()
!_ = trace ("\n%%%%%%%%%%%%%%% se' %\n"++se') $ ()
#endif
e_ = gExpandTypeSynonyms e
se_ = showSDoc dflags $ ppr e_
se = sanitiseTypeString se_
#if TRY_NO_SEQAIDDISPATCH_INTERMEDIARY
#if SEQABLE_ONLY
marr = (se =~ "Control.DeepSeq.Bounded.Seqable.force_ *@ ") :: MatchArray
#else
#if TRY_SIMPLY_NFDATA
marr = (se =~ "Control.DeepSeq.force *@ ") :: MatchArray
#else
#if NFDATAN_ONLY
marr = (se =~ "Control.DeepSeq.Bounded.NFDataN.forcen *@ ") :: MatchArray
#else
marr = (se =~ "Control.DeepSeq.Bounded.NFDataP.forcep *@ ") :: MatchArray
#endif
#endif
#endif
#else
marr = (se =~ "Seqaid.Runtime.seqaidDispatch *@ ") :: MatchArray
#endif
(a,b) = (marr!0)
se'' = drop (a+b) se
se''' = reverse $ dropWhile (==' ') $ (\(h:t) -> if h == '.' then dropWhile (/=' ') t else (h:t)) $ reverse $ takeWhile (\c->c/='$'&&c/='\n') se''
se' = if head se''' == '(' then se''' else "("++se'''++")"
sn = showSDoc dflags $ ppr n
cleanupMap :: [(String,String)] -> Map String Int -> Map String Int
cleanupMap [] m = m
cleanupMap ((x,r):t) m = cleanupMap t m'
where
mmv = Map.lookup x m
m' | isNothing mmv = m
| otherwise = m'''
where
Just lav = mmv
m'' = Map.delete x m
m''' = Map.insert r lav m''
seqinjectFuncPlus :: Map String Int -> [CoreBind] -> ModGuts -> [String] -> CoreBindMeta -> CoreM CoreBind
seqinjectFuncPlus seqinj_map seqinj_binds guts types (Excl siteid b) = return b
seqinjectFuncPlus seqinj_map seqinj_binds guts types cbm@(Incl siteid dododo@(do_wrap,do_man,do_typ) x) = do
dflags <- getDynFlags
#if DBG_SEQINJECT_FUNC
putMsgS "seqinjectFuncPlus:"
prBind dflags x
#endif
#if INFER_TOP_LEVEL_TYPES
cb' <- if do_wrap
then seqinjectFunc seqinj_map seqinj_binds guts cbm
else return x
#else
let cb' = x
#endif
cb <- if do_man || do_typ
then setManualSiteIDsAndDoTypesBasedSubexpressionInjections dflags dododo seqinj_map seqinj_binds guts types cb'
else return cb'
return cb
seqinjectFunc :: Map String Int -> [CoreBind] -> ModGuts -> CoreBindMeta -> CoreM CoreBind
seqinjectFunc seqinj_map seqinj_binds guts (Excl siteid b) = return b
seqinjectFunc seqinj_map seqinj_binds guts (Incl siteid dododo@(do_wrap,do_man,do_typ) (x@(NonRec b e))) = do
dflags <- getDynFlags
let nb = nameOfBind dflags x
#if DBG_SEQINJECT_FUNC
putMsgS $ "!!seqinjectFunc!! " ++ nb
#endif
tstr <- sanitiseTypeStringExpr dflags e
#if 0 || DBG
let !_ = putMsgS $ "tstr = " ++ tstr
#endif
let banned_list = []
if or $ map (flip isPrefixOf tstr) banned_list
then do
#if DBG_MAP_LOOKUP
let !_ = trace "-->>banned<<--" $ ()
#endif
return x
else do
let midx =
#if DBG_MAP_LOOKUP
trace (" ++++++>> " ++ tstr ++ " << " ++ (showSDoc dflags $ ppr (exprType e)) ++ " >> ") $
#endif
if head tstr == '('
then Map.lookup ( tstr ) seqinj_map
else Map.lookup ("("++tstr++")") seqinj_map
if isNothing midx
then do
#if ! NO_WARN_SITE_MISSING_INSTANCE
#if SEQABLE_ONLY
putMsgS $ "seqaid: warning: couldn't find SOP Generic instance for type\n " ++ tstr
#else
#if NFDATAN_ONLY
putMsgS $ "seqaid: warning: couldn't find NFDataN instance for type\n " ++ tstr
#else
putMsgS $ "seqaid: warning: couldn't find NFDataP instance for type\n " ++ tstr
#endif
#endif
#endif
return x
else do
let idx = fromJust midx
the_force_var <- getBindRHS guts dflags $ seqinj_binds!!idx
#if 0 || DBG
let !_ = trace ("\n@@@@@@@@@@@@@@@@\n"++(showSDoc dflags $ ppr x)) $ ()
let !_ = trace ("\n!!!!!!!!!!!!!!!!\n"++(showSDoc dflags $ ppr the_force_var)) $ ()
let !_ = trace ("\n????????????????\n"++(showSDoc dflags $ ppr e )++"\n") $ ()
#endif
#if DRY_RUN
let e' = e
#else
let bs = pad 10 $ showSDoc dflags $ ppr b
bse <- mkStringExpr bs
let (ebs,ee) = collectBinders e
let e'' = mkCoreApp
( mkCoreApp
the_force_var
( let idx = fst3 siteid in
( mkCoreTup
[ mkIntExprInt dflags idx
, bse
#if DEMO_MODE
, mkIntExprInt dflags 0
#else
, mkIntExprInt dflags $ hash $ bs ++ show idx
#endif
]
)
)
)
ee
let e' = mkCoreLams ebs e''
#endif
return $ NonRec b e'
seqinjectFunc seqinj_map seqinj_binds guts (Incl siteid dododo (x@(Rec bes))) = do
bes' <- mapM (\ (b,e) -> do { (NonRec b' e') <- seqinjectFunc seqinj_map seqinj_binds guts (Incl siteid dododo (NonRec b e)) ; return (b',e') } ) bes
return $ Rec bes'
setManualSiteIDsAndDoTypesBasedSubexpressionInjections :: DynFlags -> (Bool,Bool,Bool) -> Map String Int -> [CoreBind] -> ModGuts -> [String] -> CoreBind -> CoreM CoreBind
setManualSiteIDsAndDoTypesBasedSubexpressionInjections dflags dododo@(do_wrap,do_man,do_typ) seqinj_map seqinj_binds guts types cb = do
let nb = nameOfBind dflags cb
#if DBG_SEQINJECT_FUNC
prBind dflags cb
putMsgS $ nb
#endif
let nb'= dropQuals nb
if do_man
then putMsgS $ "Manual seqaid instrumentation found: " ++ nb'
else putMsgS $ "Harnessing bind: " ++ nb'
nbe <- mkStringExpr nb
(cb',!_) <- flip runStateT (1::Int) . everywhereM (mkM (mfg do_man seqinj_map seqinj_binds guts types nb nbe)) $ cb
return cb'
where
mfg ::
Bool
-> Map String Int
-> [CoreBind]
-> ModGuts
-> [String]
-> String
-> CoreExpr
-> CoreExpr
-> StateT Int CoreM CoreExpr
mfg doman@True seqinj_map seqinj_binds guts types nb nbe app@App{} = do
let (!fun@(Var q1),q2s) = collectArgs app
let q1str = showSDoc dflags $ ppr q1
let len = length q2s
#if DBG_MANUAL
!_ <- trace ("q1str="++q1str++" |q2s|="++show len) $ return ()
!_ <- if q1str == "Seqaid.Runtime.seqaidDispatch" then trace ("len="++show len) $ return () else return ()
#endif
if q1str == "Seqaid.Runtime.seqaidDispatch"
then do
#if DBG_MANUAL
!_ <- trace (showSDoc dflags $ ppr app) $ return ()
#endif
return ()
else return ()
if len /= 7
then return app
else do
if q1str == "Seqaid.Runtime.seqaidDispatch"
then do
i <- get
#if 0 && DEMO_MODE
if i /= 6 then return app
else do
#else
do
#endif
put (1+i)
let tupcon = tupleCon BoxedTuple 3
#if DBG_MANUAL
!_ <- trace "=1==============================" $ return ()
!_ <- trace (showSDoc dflags $ ppr app) $ return ()
!_ <- trace "=2==============================" $ return ()
!_ <- trace (showSDoc dflags $ ppr q2s) $ return ()
!_ <- trace "=3==============================" $ return ()
#endif
#if DEMO_MODE
let h = 0
#else
let h = hash $ nb ++ show i
#endif
#if DBG_MANUAL
!_ <- trace (show i++" "++show nb++" "++show h) $ return ()
#endif
let blahs = [ mkIntExprInt dflags i
, nbe
, mkIntExprInt dflags h ]
let arg = mkConApp tupcon $ (map (Type . exprType) blahs) ++ blahs
#if DBG_MANUAL
!_ <- trace (showSDoc dflags $ ppr arg) $ return ()
!_ <- trace "=4==============================" $ return ()
#endif
let fun' = fun
let app' = mkCoreApps fun' $ (take (2+len) q2s) ++ [arg] ++ [last q2s]
#if DBG_MANUAL
!_ <- trace ("app before:\n"++(showSDoc dflags $ ppr app)) $ return ()
!_ <- trace ("app after:\n"++(showSDoc dflags $ ppr app')) $ return ()
!_ <- trace "=5==============================" $ return ()
#endif
#if 0
(\x -> (return $! x) >>= return) app'
return app
#else
return app'
#endif
else do
#if DBG_MANUAL
!_ <- trace "= *** 1 ==============================" $ return ()
!_ <- trace (showSDoc dflags $ ppr app) $ return ()
!_ <- trace "= *** 2 ==============================" $ return ()
#endif
return app
mfg doman@True _ _ _ _ _ _ x = return x
mfg doman@False seqinj_map seqinj_binds guts types nb nbe x@App{} = do
let tx = exprType x
if not $ isSaturatedApp tx
then do
return x
else do
#if 0
txstr <- showSDoc dflags $ ppr tx
#else
txstr <- lift $ sanitiseTypeStringExpr dflags x
#endif
#if DBG_SEQINJECT_FUNC
!_ <- trace (">> App >>>> " ++ txstr ++ " /// " ++ intercalate " " types) $ return ()
#endif
if not $ txstr `elem` types
then return x
else do
let midx =
if head txstr == '('
then Map.lookup ( txstr ) seqinj_map
else Map.lookup ("("++txstr++")") seqinj_map
if isNothing midx
then do
#if ! NO_WARN_SITE_MISSING_INSTANCE
#if SEQABLE_ONLY
!_ <- trace ("seqaid: warning: couldn't find SOP Generic instance for type\n " ++ txstr) $ return ()
#else
#if NFDATAN_ONLY
!_ <- trace ("seqaid: warning: couldn't find NFDataN instance for type\n " ++ txstr) $ return ()
#else
!_ <- trace ("seqaid: warning: couldn't find NFDataP instance for type\n " ++ txstr) $ return ()
#endif
#endif
#endif
return x
else do
#if DBG_SEQINJECT_FUNC
!_ <- trace ("<< App <<<< " ++ txstr) $ return ()
#endif
let idx = fromJust midx
the_force_var <- lift $ getBindRHS guts dflags $ seqinj_binds!!idx
i <- get
put (1+i)
let tupcon = tupleCon BoxedTuple 3
#if DEMO_MODE
let h = 0
#else
let h = hash $ nb ++ show i
#endif
let blahs = [ mkIntExprInt dflags i
, nbe
, mkIntExprInt dflags h ]
let sidarg = mkCoreTup blahs
let x' = mkCoreApp
( mkCoreApp
the_force_var
sidarg
)
x
return x'
mfg doman@False seqinj_map seqinj_binds guts types nb nbe x@Var{} = do
if exprIsVarWithFunctionType x
then return x
else do
txstr <- lift $ sanitiseTypeStringExpr dflags x
#if DBG_SEQINJECT_FUNC
!_ <- trace (">> Var >>>> " ++ txstr ++ " /// " ++ intercalate " " types) $ return ()
#endif
if not $ txstr `elem` types
then return x
else do
let midx =
if head txstr == '('
then Map.lookup ( txstr ) seqinj_map
else Map.lookup ("("++txstr++")") seqinj_map
if isNothing midx
then do
#if ! NO_WARN_SITE_MISSING_INSTANCE
#if SEQABLE_ONLY
!_ <- trace ("seqaid: warning: couldn't find SOP Generic instance for type\n " ++ txstr) $ return ()
#else
#if NFDATAN_ONLY
!_ <- trace ("seqaid: warning: couldn't find NFDataN instance for type\n " ++ txstr) $ return ()
#else
!_ <- trace ("seqaid: warning: couldn't find NFDataP instance for type\n " ++ txstr) $ return ()
#endif
#endif
#endif
return x
else do
#if DBG_SEQINJECT_FUNC
!_ <- trace ("<< Var <<<< " ++ txstr) $ return ()
#endif
let idx = fromJust midx
the_force_var <- lift $ getBindRHS guts dflags $ seqinj_binds!!idx
i <- get
put (1+i)
let tupcon = tupleCon BoxedTuple 3
#if DEMO_MODE
let h = 0
#else
let h = hash $ nb ++ show i
#endif
let blahs = [ mkIntExprInt dflags i
, nbe
, mkIntExprInt dflags h ]
let sidarg = mkCoreTup blahs
let x' = mkCoreApp
( mkCoreApp
the_force_var
sidarg
)
x
return x'
mfg doman@False seqinj_map seqinj_binds guts types nb nbe x = return x
dropQuals :: String -> String
#if 0
dropQuals = id
#else
dropQuals = reverse . takeWhile (/= '.') . reverse
#endif
sanitiseTypeStringExpr :: DynFlags -> CoreExpr -> CoreM String
sanitiseTypeStringExpr dflags e = do
let te__ = exprType e
let te_ = followArrows te__
let te = GHC.expandTypeSynonyms te_
let tstr = showSDoc dflags $ pprType te
#if DBG
let !_ = trace ("--- " ++ tstr) $ ()
#endif
let santstr = removeForallPartHack tstr
#if DBG
let !_ = trace ("+++ " ++ santstr) $ ()
#endif
return santstr
removeForallPartHack :: String -> String
removeForallPartHack s = sanitiseTypeString s_
where
#if 1
marr1 = (s =~ "^forall ") :: MatchArray
(a1,b1) = (marr1!0)
marr2 = (s =~ "=> ") :: MatchArray
(a2,b2) = (marr2!0)
s_ | null $ indices marr1 = s
| null $ indices marr2 = s
| otherwise
= dropWhile (\x -> x==' '||x=='\t'||x=='\n')
$ drop (a2+b2) s
#else
s_ | let s' = "forall " in s' == take (length s') s
= dropWhile (\x -> x==' '||x=='\t'||x=='\n')
$ drop 2
$ dropWhile (/='=') s
| otherwise
= s
#endif
sanitiseTypeString :: String -> String
sanitiseTypeString s = s''
where
s' = map (\c -> if c=='\n' then ' ' else c) s
s'' = f s'
f [] = []
f (' ':' ':cs) = f (' ':cs)
f (c:cs) = c : f cs
putmess :: String -> CoreM ()
putmess s = do
let s' = "== " ++ s ++ " "
let l = length s'
let n = max (79 l) 0
putMsgS $ s' ++ take n (repeat '=')
putendmess :: CoreM ()
putendmess = do
putMsgS $ take 79 (repeat '=')
separateDummyInstanceDecls :: String -> [String] -> [CoreBind] -> ([CoreBind],[CoreBind],[CoreBind]) -> ([CoreBind],[CoreBind],[CoreBind])
separateDummyInstanceDecls _ [] [] (acc_bs,acc_dbs,acc_mbs)
= (reverse acc_bs,reverse acc_dbs,reverse acc_mbs)
separateDummyInstanceDecls modname (n:ns) (b:bs) (acc_bs,acc_dbs,acc_mbs)
= if let x = (elision_targets!!0) in x == take (length x) n
then separateDummyInstanceDecls modname ns bs (acc_bs,acc_dbs,b:acc_mbs)
else
if let x = (elision_targets!!1) in x == take (length x) n
then separateDummyInstanceDecls modname ns bs (acc_bs,b:acc_dbs,acc_mbs)
else separateDummyInstanceDecls modname ns bs (b:acc_bs,acc_dbs,acc_mbs)
where
modname' = map (\x -> if x == '.' then '_' else x) modname
elision_targets = [ "$cseqinj_meth_" , modname++".$fSeqinjDummyClass_"++modname'++"()" ]
separateDummyInstanceDecls _ _ _ _ = error "39489387"
nameOfBind :: DynFlags -> CoreBind -> String
nameOfBind dflags bndr@(NonRec b _) = showSDoc dflags (ppr b)
nameOfBind dflags bndr@(Rec ((b,_):_)) = showSDoc dflags (ppr b)
nameOfBind dflags _ = error "nameOfBind: unexpected"
typeOfBind :: CoreBind -> Type
typeOfBind bndr@(NonRec _ e) = exprType e
typeOfBind bndr@(Rec ((_,e):_)) = exprType e
typeOfBind _ = error "typeOfBind: unexpected"
pad :: Int -> String -> String
pad n s = s ++ (take (n(length s)) $ repeat ' ')
fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,y,_) = y
thd3 :: (a,b,c) -> c
thd3 (_,_,z) = z
isSaturatedApp :: Type -> Bool
isSaturatedApp ty = b
where
b = if isFunTy ty
then False
else True
exprIsVarWithFunctionType :: CoreExpr -> Bool
exprIsVarWithFunctionType e = b
where
t = exprType e
b = case t of
GHC.FunTy arg res -> True
_ -> False
followArrows :: Type -> Type
followArrows (GHC.FunTy arg res) = followArrows res
followArrows t = t
gExpandTypeSynonyms :: CoreExpr -> CoreExpr
gExpandTypeSynonyms e = e'
where
e' = everywhere (mkT fg) e
fg :: Type -> Type
fg x = GHC.expandTypeSynonyms x
collectSubexpressionTypes :: ModGuts -> CoreM [Type]
collectSubexpressionTypes guts = do
let binds = mg_binds guts
tyss <- mapM collectSubexpressionTypesBind binds
let tys = concat tyss
return tys
collectSubexpressionTypesBind :: CoreBind -> CoreM [Type]
collectSubexpressionTypesBind (NonRec _ e) = do
(_,tys) <- flip runStateT ([]::[Type]) . everywhereM (mkM mfg) $ e
let tys' = map GHC.expandTypeSynonyms tys
return tys'
where
mfg :: CoreExpr -> StateT [Type] CoreM CoreExpr
mfg e = do
case e of
Type _ -> return e
_ -> do
tys <- get
let et = exprType e
put (et:tys)
return e
collectSubexpressionTypesBind (Rec bes) = do
tyss <- mapM (\ (b,e) -> collectSubexpressionTypesBind (NonRec b e)) bes
let tys = concat tyss
return tys
generateOmniImports :: DynFlags -> [Type] -> [String]
generateOmniImports dflags lst = imps'
where
imps = generateOmniImports' dflags lst
imps' = nub imps
generateOmniImports' :: DynFlags -> [Type] -> [String]
generateOmniImports' dflags [] = []
generateOmniImports' dflags (t:ts)
= all_imps ++ generateOmniImports' dflags ts
where
tstr = showSDoc dflags $ ppr t
all_typenames = getAllTextMatches
$ tstr =~ "[A-Z][.A-Za-z0-9_']*" :: [String]
all_typenames' = filter (/= "GHC.Prim.Void") all_typenames
all_typenames'' = filter (/= "GHC.Prim.Addr") all_typenames'
#if 1
all_typenames''' = filter (/= "Control.DeepSeq.Bounded.Pattern.Pattern") all_typenames''
all_typenames'''' = filter (/= "Seqaid.Global.SiteID") all_typenames'''
#if 1
all_splits' = catMaybes $ map splitFQN all_typenames''''
#else
all_typenames''''' = filter (/= "(Int, Int, Int, Blob Int, [Int], Int, Int, Int, Int)") all_typenames''''
all_splits' = catMaybes $ map splitFQN all_typenames'''''
#endif
#else
all_splits' = catMaybes $ map splitFQN all_typenames''
#endif
all_splits_ = map (\ (x,y) -> if x == "GHC.Prim" then ("GHC.Exts",y) else (x,y)) all_splits'
#if 1
all_splits = all_splits_
#else
all_splits = map (\ (x,y) -> if x == "GHC.Integer.Type" then ("GHC.Integer",y) else (x,y)) all_splits_
#endif
all_imps = map generateOmniImport all_splits
generateOmniImport :: (String,String) -> String
generateOmniImport (m,mt) = ( "import " ++ m ++ " ( " ++ mt ++ " )" )
splitFQN :: String -> Maybe (String,String)
splitFQN s
| '.' `elem` s = Just ( reverse $ drop 1 $ dropWhile (/='.') rs
, reverse $ takeWhile (/='.') rs
)
| otherwise = Nothing
where rs = reverse s
get_seqaid_instance_strings :: ModGuts -> CoreM [String]
get_seqaid_instance_strings guts = do
anns <- getAnnotations deserializeWithData guts
:: CoreM (UniqFM [SeqaidAnnAvailableInstances])
let annseltss = eltsUFM anns :: [[SeqaidAnnAvailableInstances]]
let annselts = concat annseltss :: [SeqaidAnnAvailableInstances]
#if TH_TYPE_IN_TYPES_ANN
let ts = concat $ map (\ (SeqaidAnnAvailableInstances tslst) -> tslst ) annselts :: [Type]
let tstrs' = map (showSDoc dflags . ppr) ts :: [String]
#else
let tstrs' = concat $ map (\ (SeqaidAnnAvailableInstances tslst) -> tslst ) annselts :: [String]
#endif
let tstrs'' = map (map (\x -> if x == '\n' then ' ' else x)) tstrs'
let compactWhite [] = []
compactWhite (' ':' ':t) = compactWhite (' ':t)
compactWhite (h:t) = h:compactWhite t
let tstrs = map ( id
. sanitiseAgain
. remove_class_str
. compactWhite
) tstrs''
return tstrs
remove_class_str :: String -> String
remove_class_str str
| ss == take lenss str = dropWhile (==' ') $ drop lenss str
| otherwise = str
where
#if SEQABLE_ONLY
ss = "Generics.SOP.Universe.Generic"
#else
#if NFDATAN_ONLY
ss = "Control.DeepSeq.Bounded.NFDataN.NFDataN"
#else
ss = "Control.DeepSeq.Bounded.NFDataP.NFDataP"
#endif
#endif
lenss = length ss
sanitiseAgain :: String -> String
sanitiseAgain str
| ( not $ null str ) && '(' /= head str = "(" ++ str ++ ")"
| otherwise = str
instancesAvailable :: [String] -> String -> Bool
instancesAvailable iss ts
| elem ts iss = True
| "(" == take 1 ts = if length (filter (==',') ts) > 7 then False else True
| elem ("("++ts++")") iss = True
| mcnm <- parse ts = if isNothing mcnm then False
else let cnm = fromJust mcnm in
cnm `elem` instance_cnms
| otherwise = False
where
parse :: String -> Maybe String
parse ('(':c:cs) = if isUpper c then Just $ parse' (c:cs)
else Nothing
parse s = Just $ parse' s
parse' s = takeWhile (/=' ') s
instance_cnms = catMaybes $ map parse iss
nubsort :: Ord a => [a] -> [a]
nubsort lst = ( map head . group . sort ) lst
assureFQN :: String -> String -> String
assureFQN thismodname name
| '.' `elem` name = name
| otherwise = thismodname ++ ('.':name)