{-# LANGUAGE CPP #-} -- For a SYB worker type signature (probably unnecessary): {- LANGUAGE FlexibleContexts #-} {- LANGUAGE PatternGuards #-} -- XXX In case didn't get around to it, there's some nonsense -- with SiteID fst3 component: The only assignments that matters -- are any made by the SYB traversal looking for manual injections. -- And this traversal will take care of auto-injected ones, too, -- they will not even need to be distinguished. -- LATER: Also now, types-based injection sets the id. -- My point above is that, we set it "early" to essentially bogus value -- which is ... need to find a moment to review that stuff. Some old -- code can definitely be removed. ------------------------------------------------------------------------------- #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 ------------------------------------------------------------------------------- -- XXX This (set =1) is probably a bad idea for a default. -- Try to minimise spurious warnings instead; although we -- don't expect spurious warnings come to think of it... #define NO_WARN_SITE_MISSING_INSTANCE 0 -- This should be equal to Seqaid.TH's -- INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION #define DO_NOT_ELIDE_ANY_OF_THE_INJECTED_TH_SPLICES 1 -- Hack to try using class method instead of seqaidDispatch intermediary. #define TRY_NO_SEQAIDDISPATCH_INTERMEDIARY 0 #define TRY_SIMPLY_NFDATA 0 -- Run "as much of thie module's code as possible" without -- altering the original bindings. (There may be lack-of-demand -- issues here...). #define DRY_RUN 0 -- Return guts unmodified; skips most of this module's code. #define BYPASS 0 -- Not necessary (was trying to simplify debugging at one point). #define EXCLUDE_COLON_MAIN 0 ------------------------------------------------------------------------------- -- XXX Initially templated from the -- strict-ghc-plugin (Austin Seipp / thoughtpolice). -- XXX Comments below are now very old (from like, 1st or 2nd day -- of working on the plugin): -- -- -- Overview of the Problem -- -- ======================= -- -- -- -- Want to inject CoreSyn Expr App of an imported, polymorphic function -- -- (which uses methods of a certain class), to any suitable expression. -- -- By suitable, meaning we may assume that the class instance exists -- -- for the type of the expression, so that (or rather, because) the class -- -- type constraint is satisfied. -- -- -- -- The problem is, how to express this with hand-coded core injection? -- -- -- -- I have some notion that, in Core, an overloaded function is really -- -- a monomorphic function taking an additional dictionary argument. -- -- What I can't find a good explanation of is, what, more concretely -- -- (as befits a person trying to write a plugin, say...) can a person -- -- do to inject such a function application to (perhaps annotated) -- -- expressions? I feel this is a good question (even for SO), since -- -- it's such a natural and powerful thing to want to be able to do -- -- in a plugin. -- -- -- -- Well, I could test that I have a good grasp on doing this -- -- for a MONOMORPHIC function -- but then, aren't I already -- -- doing that in effect, with my single, Float-specialised seqaid_dud? ------------------------------------------------------------------------------- -- -- What follows is a wretched hack until further notice. -- -- -- 20140930 Getting closer. Dictionary manipulation (or Rules) -- -- is probably the way to go -- unless there actually are API -- -- functions to help do this? -- -- In the meantime, can try to examine at the ctor level, -- -- what I get as input to Core level ("simplifier?") ... should -- -- actually double-check where in the pipeline this plugin -- -- plugs-in... -- -- And from Seqaid.Plugin.install: -- -- return $ CoreDoPluginPass "Seqinject" seqinjectProgram : todos -- -- So we inject (er, another use of the term) the seqaid plugin -- -- at the very front. So we're interested in what manually-coded -- -- calls to the injection function will look like at that point. -- -- In principle, if can imitate that, ab initio, if we're "pure" [?] -- -- (though we're in a monad...) we should get the same behaviour. -- -- But environment ... the state of the CoreM monad must be consistent. -- -- -- 20140929 A few days into this; so far, it is finally working -- -- but only for the type of the seqaid_dud declaration (which -- -- must be monomorphic or you get an error when plugin runs). -- -- So the code contains working seqaidDispatch injections -- -- at the original, manually-injected @Bool site, and at (the) -- -- two @Float sites where we lucked out and had the right type -- -- specialisation for the expression. -- -- The other cases seem to "do nothing" (trace in seqaidDispatch -- -- not printed), but no harm ensues. {-# LANGUAGE PatternGuards #-} {-# LANGUAGE BangPatterns #-} -- debugging only! ------------------------------------------------------------------------------- -- | -- Module : Seqaid.Core -- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk -- Stability : provisional -- Portability : GHC -- -- Instrument a program with dynamic forcing functions. -- -- This module is for internal use with the seqaid GHC plugin. -- -- Refer to -- -- for more information about this methodology. ------------------------------------------------------------------------------- module Seqaid.Core ( seqinjectProgram ) where -- XXX for debugging only (prefer deepseq-bounded import, since then -- no need to state deepseq (or deepseq-generics) dep in .cabal. import Control.DeepSeq.Bounded ( force ) --import Control.DeepSeq.Generics ( force ) -- XXX for debugging only --import Control.DeepSeq ( force ) -- XXX for debugging only --import Data.Generics.Shape.SYB import GhcPlugins import Control.Monad import Data.Generics import Seqaid.Ann import Seqaid.Runtime ( SiteID ) --import qualified Var as GHC 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 GHC.Paths as GHC ( libdir ) -- package ghc-paths 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 GhcMonad ( liftIO ) 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 = -- (Bool,Bool) = (do_wrap_RHS, do_all_manual_within) Incl SiteID (Bool,Bool,Bool) CoreBind | Excl SiteID CoreBind --- | Manual CoreBind --data CoreBindMeta = Incl SiteID CoreBind | Excl SiteID CoreBind unMeta :: CoreBindMeta -> CoreBind unMeta (Incl _ _ b) = b --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 -- error "Core.hs-DEVEXIT" #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 -- XXX Here we need to traverse the binds, collect the -- types of all subexpressions, and dump the (nubbed) -- collection to a temp file for seqaidpp to pick up. -- putMsgS "\nBoo!!\n" let omni_types_pname = opts!!1 let omni_imports_pname = opts!!2 -- putMsgS $ "WOULD WRITE " ++ omni_types_pname seqaid_instance_strings <- get_seqaid_instance_strings guts #if DBG_OMNI putMsgS $ " XXX seqaid_instance_strings =\n" ++ intercalate "\n" seqaid_instance_strings -- error "DEVEXIT" #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''' -- (Can't nub the [Type], there's no Eq instance for Type.) 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 -- sort not nec. to nub, but it's helpful to see them sorted; -- wrote nubsort as it's more efficient than (nub . sort). 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''' -- XXX Not sure if we should exclude boxed types or what... 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 -- error "DEVEXIT" #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' -- let omni_imports_string = "" -- XXX thack! liftIO $ writeFile omni_imports_pname omni_imports_string return guts else do -- XXX Why am I content to just look at the head? -- I /have/ seen more than one module name in a list! -- (In fact, there's code someplace below to work around this, -- or is it in the TH code?...) anns <- getAnnotations deserializeWithData guts :: CoreM (UniqFM [SeqaidAnnIncludeList]) -- (signature required) 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] -- Support for manually-instrumented code (Seqaid.Runtime.seqaid) -- requires also giving the SeqaidAnnManual ANN pragma, for now. mananns <- getAnnotations deserializeWithData guts :: CoreM (UniqFM [SeqaidAnnManual]) -- (signature required) let manannseltss = eltsUFM mananns :: [[SeqaidAnnManual]] let manannselts_ = concat manannseltss :: [SeqaidAnnManual] -- Drop Manual ANN's which name something outside the current module! let manannselts' = filter ( \ (SeqaidAnnManual y) -> not (elem '.' y) || thismodname /= takeWhile (/='.') y ) manannselts_ :: [SeqaidAnnManual] -- Now assure all are fully-qualified: let manannselts = map ( \ (SeqaidAnnManual y) -> SeqaidAnnManual (if elem '.' y then y else thismodname++"."++y) ) manannselts' :: [SeqaidAnnManual] typanns <- getAnnotations deserializeWithData guts :: CoreM (UniqFM [SeqaidAnnTypes]) -- (signature required) 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]) -- (sig. required) 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 $ "anns = " ++ show anns --- putMsgS $ "anns = " ++ showSDoc dflags (ppr anns) putMsgS $ "annseltss = " ++ concatMap (('\n':) . show) annseltss putMsgS $ "annselts = " ++ concatMap (('\n':) . show) annselts -- putMsgS $ "annselts = " ++ intercalate " " ( map show annselts ) -- putMsgS $ "annseltss = " ++ intercalate " " ( map (showSDoc dflags . ppr) annseltss ) -- putMsgS $ "annselts = " ++ intercalate " " ( map (showSDoc dflags . ppr) 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 ) -- if null annselts && null manannselts && null types -- if null annselts && null manannselts && null typannselts -- if null annselts then do #if MENTION_EXCLUDED #if ! SILENT putMsgS $ "Excluded from seqaid harness: " ++ thismodname #endif #endif return $ guts else do #if ! SILENT -- Used to print "Included in seqaid harness: ..." message here. -- Then, it was moved downstream to become per-bind. -- But finally, now it's done in TH.hs, so it can appear before -- other messages from TH. #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 (putStrLn . (prBindWithType dflags)) binds_ mapM (prBindWithType dflags) binds_ -- mapM (printBind dflags) binds_ -- putMsgS $ showSDoc dflags (ppr binds_) putendmess -- error "STOP" #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 -- putMsgS $ showSDoc dflags (ppr binds) putmess "ppr dbinds" mapM (printBind dflags) dbinds putmess "ppr mbinds" mapM (printBind dflags) mbinds putendmess -- error "STOP" #endif let (seqinj_noninst_binds, non_seqinj_binds'') #if NO_TOP_LEVEL_SEQINJ_DUMMIES = collectSeqinjBinds dflags "$cseqinj" mbinds ([],[]) --- = collectSeqinjBinds dflags "$cseqinj" binds ([],[]) ---- = collectSeqinjBinds dflags (thismodname++".$cseqinj") binds ([],[]) #else = collectSeqinjBinds dflags (thismodname++".seqinj") binds ([],[]) #endif #if DBG_BINDS putmess "ppr seqinj_noninst_binds" mapM (printBind dflags) seqinj_noninst_binds -- putMsgS $ showSDoc dflags (ppr seqinj_noninst_binds) putendmess putmess "ppr non_seqinj_binds''" mapM (printBind dflags) non_seqinj_binds'' -- putMsgS $ showSDoc dflags (ppr 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 -- putMsgS $ showSDoc dflags (ppr seqinj_inst_binds) putendmess putmess "ppr non_seqinj_binds'" mapM (printBind dflags) non_seqinj_binds' -- putMsgS $ showSDoc dflags (ppr 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 -- putMsgS $ showSDoc dflags (ppr seqinj_noninst_binds) putendmess #endif #if 1 putmess "ppr seqinj_inst_binds" mapM (printBind dflags) seqinj_inst_binds -- putMsgS $ showSDoc dflags (ppr 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 -- putMsgS $ showSDoc dflags (ppr 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 -- XXX By sending 1 as initial siteid, I'm implicitly subscribing -- to the dangerous idea that reserving siteid=0 might be useful... -- As for -ve Int's, I have (according to warning message the TH -- part issues if user attempts to auto-harness a polymorphic bind) -- that these are reserved for manual injections (where assuring -- their uniqueness unfortunately becomes the user's responsibility). <- 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 -- putMsgS $ showSDoc dflags (ppr non_seqinj_binds_included) putendmess #endif -- This is all the local variables referring to some binds! -- (I'm debugging why my Map is empty at the moment...). -- Apparently, seqinj_binds is [] at this point! -- But anyway, seqinj_binds = seqinj_inst_binds ++ seqinj_noninst_binds. -- And ... and, yeah, both of those on the RHS are indeed (of course), []... --- binds --- seqinj_noninst_binds --- non_seqinj_binds'' --- seqinj_inst_binds --- non_seqinj_binds' --- seqinj_binds --- non_seqinj_binds --- non_seqinj_binds_synthetic --- non_seqinj_binds_user --- non_seqinj_binds_included --- non_seqinj_binds_excluded 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 -- putMsgS $ showSDoc dflags (ppr seqinj_map) putendmess #endif #endif #if DBG_BINDS putmess "ppr non_seqinj_binds_meta" mapM (prMetaBind dflags) non_seqinj_binds_meta -- putMsgS $ showSDoc dflags (ppr non_seqinj_binds_meta) putendmess #endif -- error "STOP" newBinds' <- mapM (seqinjectFuncPlus seqinj_map seqinj_binds guts types) non_seqinj_binds_meta -- (map unMeta non_seqinj_binds_meta) -- oops! -- Don't do any unnecessary reordering of included and excluded; -- implement so can preserve (or restore) original ordering to -- declarations, to the greatest possible extent... let newBinds'' = non_seqinj_binds_synthetic #if DO_NOT_ELIDE_ANY_OF_THE_INJECTED_TH_SPLICES -- XXX all are needed! (when last I checked) -- or you need some environment modifcn... -- (This is when using -- INJECT_DUMMY_CLASS_AND_INSTANCE_TO_BLOCK_DEAD_CODE_ELIMINATION -- in Seqaid/TH.hs.) -- As for this, if you don't, then you get duplicate mbinds. #if ! NO_TOP_LEVEL_SEQINJ_DUMMIES ++ seqinj_binds #endif ++ mbinds ++ dbinds #endif ++ newBinds' -- which now includes non_seqinj_binds_excluded -- interleaved in the original order (nec.) #if EXCLUDE_COLON_MAIN let newBinds = newBinds'' ++ [colon_main_bind] #else let newBinds = newBinds'' #endif #if DBG_BINDS #if 1 putmess "ppr newBinds" -- mapM (printBind dflags) newBinds -- names only putMsgS $ showSDoc dflags (ppr newBinds) -- full decls 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 [] r@(ss,us) = r splitSynthUser dflags (h:t) (ss,us) = case h of bndr@(NonRec b _) -> if head (showSDoc dflags (ppr b)) == '$' -- if head 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) -- error "#2093857" ------------------------------------------------------------------------------- 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 --- | bndr@(Rec bes) <- h = error "markNonSeqinjBinds: Rec unimplemeted!" | otherwise = error "markNonSeqinjBinds: unexpected!" where -- XXX I'm pretty sure all but the name part (snd3 component) are -- going to get overwritten downstream, now, since planning to -- support manual injection via SYB renumbering... -- (That's okay though; and doing this still here will help -- keep old code working that bit longer while transition...) (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) -- siteid_next = (1 + fst siteid, snd siteid) ------------------------------------------------------------------------------- -- Note this is not general-purpose; it is for getting the RHS's -- of seqinj_* binds. getBindRHS :: ModGuts -> DynFlags -> CoreBind -> CoreM CoreExpr getBindRHS guts dflags bind = do -- I don't recall seeing these traces for some time, actually?... #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 -- shouldn't happen | 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) -- XXX not sure why I'm not reversing here; compensating for elsewhere??... = #if DBG trace "&&-[]-&&" $ #endif (seqinjbs, nonseqinjbs) -- = (reverse seqinjbs, reverse 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) ------------------------------------------------------------------------------- -- We already know it's all NonRec's. -- Okay, this is almost right, but it's going to need types. -- No use for keys "seqinj_7" etc.! Need keys to be whatever -- exprType returns, and we can find out exactly by using -- it on those seqinj's RHS's (complicated by the fact that -- it's -> , and we only really want ). makeMapSeqinjBinds :: DynFlags -> [CoreBind] -> Map String Int makeMapSeqinjBinds dflags lst -- = error (intercalate "\n" $ map show $ Map.toList themap2) = #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 -- go i ((Rec bes):t) = (se', i) : go (1+i) t where -- We only need the name of the bind, and the type of the RHS. Since every -- binding in the group must have the same type, we only look at the first. (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 ((Rec _):t) = error "makeMapSeqinjBinds: Rec's not yet handled!!" 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') $ () --- !_ = trace se' $ () ---- !_ = trace (showSDoc dflags $ ppr e) $ error "" :: () #endif e_ = gExpandTypeSynonyms e se_ = showSDoc dflags $ ppr e_ se = sanitiseTypeString se_ #if TRY_NO_SEQAIDDISPATCH_INTERMEDIARY -- XXX Not tested in a long while. #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 -- marr = (se =~ "Control.DeepSeq.Bounded.NFDataN.forcen *@ ") :: MatchArray #endif #endif #endif #else marr = (se =~ "Seqaid.Runtime.seqaidDispatch *@ ") :: MatchArray -- marr = (se =~ "Seqaid.Runtime.seqaidDispatch\n *@ ") :: MatchArray #endif (a,b) = (marr!0) se'' = drop (a+b) se -- this needed for imported types 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 = [] -- (vestigial) 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 ! SILENT #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 -- XXX hardcode (however, pad never truncates) let bs = pad 10 $ showSDoc dflags $ ppr b -- let bs = showSDoc dflags $ ppr b bse <- mkStringExpr bs -- We need to inject to the right of any initial lambda bindings; -- joining us for this occasion: -- collectBinders :: Expr b -> ([b], Expr b) -- mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr 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' ------------------------------------------------------------------------------- -- A bit later: Now I'm going to try adding the types-based site -- selection to this (seqiad.config). But I'm going to clone the -- existing SYB traversal and run a second traversal instead?... -- Er, no. -- Keep them together, and then can avoid doing double (which would -- be a user error anyhow -- if they manually injected, as well as -- listed the type in their seqaid.config, they're asking for double, -- but may as well code it right and prevent redundant wrapping even -- in such cases... ------ -- Note that, at present, this function is only called for binds -- which have a {-# ANN module (SeqaidAnnManual "funcname") #-} -- present in the same file (typically, but not necessarily, -- at the declaration head). Would prefer to auto-detect the -- seqaid applications, but don't know how yet (TH staging woes). 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 -- let (cb',!_) = flip runStateT (1::Int) . everywhereM (mkM (mfg do_man seqinj_map seqinj_binds guts types nb nbe)) $ cb -- let (cb',!_) = flip runState (1::Int) . everywhereM (mkM (mfg do_man seqinj_map seqinj_binds guts types nb nbe)) $ cb return cb' where {- NOINLINE mfg #-} -- XXX It would be nice to nudge the SYB traversal along, past -- this application of seqaid*, since otherwise there will be -- testing some descendants in vain ... but never mind for now; -- that's an optimisation... mfg :: Bool -- process for Manual injection -> Map String Int -- seqinj_map ("the Map") -> [CoreBind] -- seqinj_binds (seqinj_[0-9]*) -> ModGuts -- guts ("the guts") -> [String] -- types (from seqaid.config) -> String -- nb (name of bind being processed) -> CoreExpr -- nbe (mkStringExpr nb) -> CoreExpr -- node in Core AST (SYB traversal) -> StateT Int CoreM CoreExpr -- result (refactored Core AST) -- mfg seqinj_map seqinj_binds guts types nb nbe app@App{} = do -- mfg :: Map String Int -> [CoreBind] -> ModGuts -> [String] -> String -> CoreExpr -> CoreExpr -> State Int CoreExpr -- XXX decided to just make Manual and types-based mutually-exclusive -- to start with here... When get to allow both at once again, -- definitely a single traversal is appropriate. Just for the SiteID -- indexing if nothing else!... --- #if ! SEQAIDPP_TYPES -- XXX note that now, with the types-based coming in, we're not -- only wrapping App nodes; so the catch-all case below this -- needs to do wrapping too. But we do need an App-node case -- because want to avoid redundant wrapping. 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 q1 /= nam then error "UNEXPECTED!" else 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 -- XXX won't catch the "seqaid $" wrapper pattern, though! then return app else do if q1str == "Seqaid.Runtime.seqaidDispatch" then do i <- get #if 0 && DEMO_MODE -- This caused Prelude.undefined errors at runtime last I checked. -- XXX note that, with this, the State "put" below is conditional, -- which is a recipe for a space leak... ("ironically") -- XXX This is totally fragile; it's very much a hack demo mode thing! if i /= 6 then return app else do #else do #endif put (1+i) -- let tupcon = tupleCon UnboxedTuple 3 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 tuptycon = mkTupleTy UnboxedTuple (map (Type . exprType) blahs) 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 (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 --- #else -- x is any CoreExpr except for an App node (which is covered above) -- Later: No it isn't covered above! I vaguely recall what I meant -- by that at the time, but I don't see it now... -- mfg doman@False seqinj_map seqinj_binds guts types nb nbe x = do mfg doman@False seqinj_map seqinj_binds guts types nb nbe x@App{} = do --isSaturatedApp :: DynFlags -> Type -> Bool 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 -- XXX User should refrain from ()-ing in seqaid.config; this -- is not enough anyway, as they could even go types: (((Int)))... 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 ! SILENT #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 UnboxedTuple 3 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 sidarg = mkConApp tupcon $ (map (Type . exprType) blahs) ++ 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 -- XXX User should refrain from ()-ing in seqaid.config; this -- is not enough anyway, as they could even go types: (((Int)))... 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 ! SILENT #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 UnboxedTuple 3 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 sidarg = mkConApp tupcon $ (map (Type . exprType) blahs) ++ 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 --- #endif ------------------------------------------------------------------------------- dropQuals :: String -> String #if 0 dropQuals = id #else -- XXX WARNING: This is causing errors for some types! -- For instance, a type which contains a type-subexpression -- which itself contains a qualified type name. dropQuals = reverse . takeWhile (/= '.') . reverse #endif ------------------------------------------------------------------------------- sanitiseTypeStringExpr :: DynFlags -> CoreExpr -> CoreM String sanitiseTypeStringExpr dflags e = do let te__ = exprType e -- XXX is there not a GHC API function I saw for this?... let te_ = followArrows te__ -- use the result type let te = GHC.expandTypeSynonyms te_ let tstr = showSDoc dflags $ pprType te #if DBG let !_ = trace ("--- " ++ tstr) $ () #endif let santstr = removeForallPartHack tstr -- let santstr = tstr -- let santstr = sanitiseTypeString_old tstr #if DBG let !_ = trace ("+++ " ++ santstr) $ () #endif return santstr ------------------------------------------------------------------------------- -- XXX VERY BAD INDEED!!! 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 '=') ------------------------------------------------------------------------------- -- Not the most efficient but whatever. -- Also, I don't like writing monadic code, so the caller computes -- the String names of the binds, and passes them. 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'++"()" ] -- elision_targets = [ "$cseqinj_meth_" , modname++".$fSeqinjDummyClass()" ] 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 ------------------------------------------------------------------------------- -- These two used to be in different spots in this file. -- I'm not sure they're both needed/wanted?... isSaturatedApp :: Type -> Bool isSaturatedApp ty = b where b = if isFunTy ty then {- trace ("isSaturatedApp: FALSE ") $ -} False else {- trace ("isSaturatedApp: TRUE " ) $ -} 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 ------------------------------------------------------------------------------- -- XXX The SYB traversal need not be monadic. -- Possibly, the CoreM monad is not even needed... 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' -- return tys -- return $ nub tys -- no Eq instance! 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 -- This is ridiculously costly, but at this point that's -- not a concern. imps' = nub imps -- have to, even though the lst was pre-nubbed, -- because we're extracting subtypes in here -- XXX In here we have some very brutal hacks, just to get -- proof-of-concept happening. Do something better!... 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 -- (we don't handle tuples with more than 7 components at this time) 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]) -- (signature required) 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 -- Some types are wrapped in (...). -- Others are not. -- And even some (but not all!) tuples are double-wrapped [eg. ((a,b))]. -- Not sure what can do about the latter. -- But the former, as done before, can just assure wrap if not wrapped... sanitiseAgain :: String -> String sanitiseAgain str | ( not $ null str ) && '(' /= head str = "(" ++ str ++ ")" | otherwise = str -- I just can't stand this! --- | ( not $ null str ) && '(' /= head str = '(' : ( str ++ ")" ) ------------------------------------------------------------------------------- -- This isn't the best name; but it is obviously a predicate, so it's okay. -- Also, this is not really internally (logically) consistent, -- with respect to parentheses. (But I'm grasping here...) instancesAvailable :: [String] -> String -> Bool instancesAvailable iss ts | elem ts iss = True -- ... and yes, this bit us (kinda expected; welcome -- to see it actually): 9-tuple in leaky.hs!... -- So we will count commas for now, as this DOES at least -- form a safe bound; there can only be MORE commas due -- to any nesting we're not accounting for! | "(" == take 1 ts = if length (filter (==',') ts) > 7 then False else True | elem ("("++ts++")") iss = True -- XXX this should at least go as far as to recursively call -- instancesAvailable on the argument(s) to type constructors. | 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 ------------------------------------------------------------------------------- -- O(n*logn + n), versus (nub . sort) or (sort . nub), both of -- which are O(n^2) because nub is. Just maybe, nub has lower -- average case complexity when fed a sorted list? Here is -- the GHC source for nub. --------------------------------------- -- -- stolen from HBC -- nub l = nub' l [] -- where -- nub' [] _ = [] -- nub' (x:xs) ls -- | x `elem` ls = nub' xs ls -- | otherwise = x : nub' xs (x:ls) --------------------------------------- -- elem _ [] = False -- elem x (y:ys) = x==y || elem x ys --------------------------------------- -- So nub will behave pathologically badly for a list with -- no two equal elements, due to worst-case linear complexity -- of elem. nubsort :: Ord a => [a] -> [a] nubsort lst = ( map head . group . sort ) lst -- O(nlogn) --nubsort lst = nub $ sort lst -- O(n^2)! ------------------------------------------------------------------------------- assureFQN :: String -> String -> String assureFQN thismodname name | '.' `elem` name = name | otherwise = thismodname ++ ('.':name) -------------------------------------------------------------------------------