Skip to content

Commit 9fe95b1

Browse files
TritloTritlo
authored
Avoid trace correlation by using expressions directly. Fixes #92 (#95)
1 parent b9fd489 commit 9fe95b1

File tree

9 files changed

+122
-119
lines changed

9 files changed

+122
-119
lines changed

‎src/Endemic/Check.hs

+5
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,11 @@ baseFun nm val =
6969
elb :: LHsLocalBinds GhcPs
7070
elb = noLoc $ EmptyLocalBinds NoExtField
7171

72+
-- | Unpacks a function defined by baseFun
73+
unFun :: HsBind GhcPs -> Maybe (LHsExpr GhcPs)
74+
unFun (FunBind _ _ (MG _ ((L _ [L _ (Match _ _ _ (GRHSs _ [L _ (GRHS _ _ ex)] _))])) _) _ _) = Just ex
75+
unFun _ = Nothing
76+
7277
-- Shorthands for common constructs
7378

7479
-- | Short for "the function"

‎src/Endemic/Eval.hs

+51-75
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ import Data.Dynamic (Dynamic, fromDynamic)
4242
import Data.Function (on)
4343
import Data.IORef (IORef, newIORef, readIORef)
4444
import Data.List (groupBy, intercalate, nub, partition, stripPrefix)
45+
import Data.Map (Map)
4546
import qualified Data.Map as Map
4647
import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe)
4748
import Data.Set (Set)
@@ -649,44 +650,6 @@ moduleToProb baseCC@CompConf {tempDirBase = baseTempDir, ..} mod_path mb_target
649650
-- _ -> int_prob
650651
return (cc', tc_modul, int_prob)
651652

652-
-- Create a fake base loc for a trace.
653-
fakeBaseLoc :: CompileConfig -> EProblem -> EProgFix -> Ghc SrcSpan
654-
fakeBaseLoc cc prob (fix : _) = getLoc . head <$> buildTraceCorrelExpr cc prob fix
655-
fakeBaseLoc cc prob [] = error "Cannot construct base loc for empty prog!"
656-
657-
-- When we do the trace, we use a "fake_target" function. This build the
658-
-- corresponding expression,
659-
buildTraceCorrelExpr :: CompileConfig -> EProblem -> EExpr -> Ghc [LHsExpr GhcPs]
660-
buildTraceCorrelExpr cc EProb {..} expr = do
661-
let correl =
662-
map (\(nm, _, _) -> baseFun (mkVarUnqual $ fsLit $ "fake_target_" ++ rdrNamePrint nm) expr) e_prog
663-
correl_ctxts :: [LHsLocalBinds GhcPs]
664-
correl_ctxts = map (\c -> noLoc $ HsValBinds NoExtField (ValBinds NoExtField (unitBag c) [])) correl
665-
correl_exprs :: [LHsExpr GhcPs]
666-
correl_exprs = map (\ctxt -> noLoc $ HsLet NoExtField ctxt (noLoc hole)) correl_ctxts
667-
668-
pcorrels <- mapM (parseExprNoInit . showUnsafe) correl_exprs
669-
let getBod (L _ (HsLet _ (L _ (HsValBinds _ (ValBinds _ bg _))) _))
670-
| [L _ FunBind {fun_matches = MG {mg_alts = (L _ alts)}}] <- bagToList bg,
671-
[L _ Match {m_grhss = GRHSs {grhssGRHSs = [L _ (GRHS _ _ bod)]}}] <- alts =
672-
Just bod
673-
getBod _ = Nothing
674-
return $ mapMaybe getBod pcorrels
675-
buildTraceCorrelExpr _ _ _ = error "External fixes not supported!"
676-
677-
-- We build a Map from the traced expression and to the original so we can
678-
-- correlate the trace information with the expression we're checking.
679-
-- This helps e.g. to find placements of changed elements (in our fixes) to the original position.
680-
buildTraceCorrel :: CompileConfig -> EProblem -> EExpr -> Ghc [Map.Map SrcSpan SrcSpan]
681-
buildTraceCorrel cc prob expr = do
682-
map toCorrel <$> buildTraceCorrelExpr cc prob expr
683-
where
684-
expr_exprs = flattenExpr expr
685-
toCorrel trace_expr = Map.fromList $ filter (\(e, b) -> isGoodSrcSpan e && isGoodSrcSpan b) locPairs
686-
where
687-
trace_exprs = flattenExpr trace_expr
688-
locPairs = zipWith (\t e -> (getLoc t, getLoc e)) trace_exprs expr_exprs
689-
690653
-- | Runs a GHC action and cleans up any hpc-directories that might have been
691654
-- created as a side-effect.
692655
-- TODO: Does this slow things down massively? We lose out on the pre-generated
@@ -762,12 +725,22 @@ traceTarget ::
762725
EProp ->
763726
[RExpr] ->
764727
IO (Maybe TraceRes)
765-
traceTarget cc tp e fp ce = head <$> (traceTargets cc tp e [(fp, ce)])
728+
traceTarget cc tp e fp ce = head <$> traceTargets cc tp e [(fp, ce)]
766729

767-
toInvokes :: Trace -> Map.Map SrcSpan Integer
768-
toInvokes res = Map.fromList $ map only_max $ flatten res
730+
toInvokes :: Trace -> Map.Map (EExpr, SrcSpan) Integer
731+
toInvokes (ex, res) = Map.fromList $ mapMaybe only_max $ flatten res
769732
where
770-
only_max (src, r) = (mkInteractive src, maximum $ map snd r)
733+
isOkBox (ExpBox _, _) = True
734+
isOkBox _ = False
735+
only_max :: (SrcSpan, [(BoxLabel, Integer)]) -> Maybe ((EExpr, SrcSpan), Integer)
736+
only_max (src, []) = Just ((ex, src), 0)
737+
only_max (src, [x]) | isOkBox x = Just ((ex, src), snd x)
738+
only_max (src, [x]) = Nothing
739+
-- TODO: What does it mean in HPC if there are multiple labels here?
740+
only_max (src, xs)
741+
| any isOkBox xs =
742+
Just ((ex, src), maximum $ map snd xs)
743+
only_max (src, xs) = trace (show xs) Nothing
771744

772745
-- Run HPC to get the trace information.
773746
traceTargets ::
@@ -779,19 +752,13 @@ traceTargets ::
779752
traceTargets _ _ _ [] = return []
780753
-- Note: we call runGhc' here directly, since we want every trace to be a
781754
-- new ghc thread (since we set the dynflags per module)
782-
traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
755+
traceTargets cc@CompConf {..} tp@EProb {..} exprs ps_w_ce =
783756
runGhc' cc $ do
784757
seed <- liftIO newSeed
785-
let traceHash = flip showHex "" $ abs $ hashString $ showSDocUnsafe $ ppr (exprs', ps_w_ce, seed)
758+
let traceHash = flip showHex "" $ abs $ hashString $ showSDocUnsafe $ ppr (exprs, ps_w_ce, seed)
786759
tempDir = tempDirBase </> "trace" </> traceHash
787760
the_f = tempDir </> ("FakeTraceTarget" ++ traceHash) <.> "hs"
788761
liftIO $ createDirectoryIfMissing True tempDir
789-
(exprs, realSpan) <- case exprs' of
790-
((L (RealSrcSpan realSpan) _) : _) -> return (exprs', realSpan)
791-
_ -> do
792-
~tl@(RealSrcSpan rsp) <- fakeBaseLoc cc tp exprs'
793-
let exprs = map (L tl . unLoc) exprs'
794-
return (exprs, rsp)
795762
let correl =
796763
zipWith
797764
( \(nm, _, _) e ->
@@ -801,33 +768,11 @@ traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
801768
e_prog
802769
exprs
803770
fake_target_names = Set.fromList $ map (\(n, _, _) -> n) correl
804-
toDom :: (TixModule, Mix) -> [MixEntryDom [(BoxLabel, Integer)]]
805-
toDom (TixModule _ _ _ ts, Mix _ _ _ _ es) =
806-
createMixEntryDom $ zipWith (\t (pos, bl) -> (pos, (bl, t))) ts es
807-
isTarget Node {rootLabel = (_, [(TopLevelBox [ftn], _)])} =
808-
ftn `Set.member` fake_target_names
809-
isTarget _ = False
810-
-- We convert the HpcPos to the equivalent span we would get if we'd
811-
-- parsed and compiled the expression directly.
812-
toFakeSpan :: FilePath -> HpcPos -> HpcPos -> SrcSpan
813-
toFakeSpan the_f root sp = mkSrcSpan start end
814-
where
815-
fname = fsLit $ takeFileName the_f
816-
(_, _, rel, rec) = fromHpcPos root
817-
eloff = rel - srcSpanEndLine realSpan
818-
ecoff = rec - srcSpanEndCol realSpan
819-
(sl, sc, el, ec) = fromHpcPos sp
820-
-- We add two spaces before every line in the source.
821-
start = mkSrcLoc fname (sl - eloff) (sc - ecoff -1)
822-
-- GHC Srcs end one after the end
823-
end = mkSrcLoc fname (el - eloff) (ec - ecoff)
824771
mname = filter isAlphaNum $ dropExtension $ takeFileName the_f
825772
modTxt = exprToTraceModule cc tp seed mname correl ps_w_ce
826773
exeName = dropExtension the_f
827774
mixFilePath = tempDir
828-
timeoutVal = fromIntegral timeout
829775

830-
liftIO $ logStr DEBUG modTxt
831776
liftIO $ writeFile the_f modTxt
832777
_ <- liftIO $ mapM (logStr DEBUG) $ lines modTxt
833778
-- We set the module as the main module, which makes GHC generate
@@ -858,6 +803,18 @@ traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
858803

859804
_ <- load (LoadUpTo target_name)
860805

806+
modul@ParsedModule {pm_parsed_source = (L _ HsModule {..})} <-
807+
getModSummary target_name >>= parseModule
808+
-- Retrieves the Values declared in the given Haskell-Module
809+
let our_targets :: Map String (LHsExpr GhcPs)
810+
our_targets = Map.fromList $ mapMaybe fromValD hsmodDecls
811+
where
812+
fromValD (L l (ValD _ b@FunBind {..}))
813+
| rdrNameToStr (unLoc fun_id) `elem` fake_target_names,
814+
Just ex <- unFun b =
815+
Just (rdrNameToStr $ unLoc fun_id, ex)
816+
fromValD _ = Nothing
817+
861818
-- We should for here in case it doesn't terminate, and modify
862819
-- the run function so that it use the trace reflect functionality
863820
-- to timeout and dump the tix file if possible.
@@ -908,21 +865,40 @@ traceTargets cc@CompConf {..} tp@EProb {..} exprs' ps_w_ce =
908865
-- TODO: When run in parallel, this can fail
909866
let rm m = (m,) <$> readMix [mixFilePath] (Right m)
910867
isTargetMod = (mname ==) . tixModuleName
868+
toDom :: (TixModule, Mix) -> [MixEntryDom [(BoxLabel, Integer)]]
869+
toDom (TixModule _ _ _ ts, Mix _ _ _ _ es) =
870+
createMixEntryDom $ zipWith (\t (pos, bl) -> (pos, (bl, t))) ts es
871+
872+
nd n@Node {rootLabel = (root, _)} =
873+
fmap (Data.Bifunctor.first (toSpan the_f)) n
874+
wTarget n@Node {rootLabel = (_, [(TopLevelBox [ftn], _)])} =
875+
(,nd n) <$> our_targets Map.!? ftn
876+
wTarget _ = Nothing
877+
-- We convert the HpcPos to the equivalent span we would get if we'd
878+
-- parsed and compiled the expression directly.
879+
toSpan :: FilePath -> HpcPos -> SrcSpan
880+
toSpan the_f sp = mkSrcSpan start end
881+
where
882+
fname = fsLit the_f
883+
(sl, sc, el, ec) = fromHpcPos sp
884+
start = mkSrcLoc fname sl sc
885+
-- HPC and GHC have different philosophies
886+
end = mkSrcLoc fname el (ec + 1)
911887
case tix of
912888
Just (Tix mods) -> do
913889
-- We throw away any extra functions in the file, such as
914890
-- the properties and the main function, and only look at
915891
-- the ticks for our expression
916892
let fake_only = filter isTargetMod mods
917-
nd n@Node {rootLabel = (root, _)} =
918-
fmap (Data.Bifunctor.first (toFakeSpan the_f root)) n
919-
res <- map nd . filter isTarget . concatMap toDom <$> mapM rm fake_only
893+
res <- mapMaybe wTarget . concatMap toDom <$> mapM rm fake_only
920894
return $ Just res
921895
_ -> return Nothing
922896

923897
res <- liftIO $ mapM (runTrace . fst) $ zip [0 ..] ps_w_ce
924898
cleanupAfterLoads tempDir mname dynFlags
925899
return res
900+
where
901+
timeoutVal = fromIntegral timeout
926902
traceTargets _ _ [] _ = error "No fix!"
927903
traceTargets _ ExProb {} _ _ = error "Exprobs not supported!"
928904

‎src/Endemic/Repair.hs

+31-19
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,11 @@
11
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE TypeFamilies #-}
23
{-# LANGUAGE LambdaCase #-}
34
{-# LANGUAGE MagicHash #-}
45
{-# LANGUAGE NumericUnderscores #-}
56
{-# LANGUAGE OverloadedStrings #-}
67
{-# LANGUAGE RecordWildCards #-}
8+
{-# LANGUAGE ScopedTypeVariables #-}
79
{-# LANGUAGE TupleSections #-}
810
{-# LANGUAGE TypeApplications #-}
911

@@ -40,6 +42,7 @@ import Data.Char (isAlphaNum)
4042
import Data.Default
4143
import Data.Dynamic (fromDyn)
4244
import Data.Either (lefts, rights)
45+
import Data.Foldable (find)
4346
import Data.Function (on)
4447
import Data.Functor (($>), (<&>))
4548
import qualified Data.Functor
@@ -174,7 +177,6 @@ getHoleFits' cc@CompConf {..} plugRef exprs = do
174177
getHoleFits' plugRef n exprs = do
175178
fits <- lefts <$> mapM (\(l, e) -> mapLeft ((e,) . zip l) <$> exprFits plugRef l e) exprs
176179
procs <- processFits $ map (second $ map (second (uncurry (++)))) fits
177-
-- pprPanic "ppr" $ ppr procs
178180
let f :: LHsExpr GhcPs -> SrcSpan -> [(Int, HsExpr GhcPs)] -> Ghc (SrcSpan, [(Int, HsExpr GhcPs)])
179181
f expr loc fits = do
180182
let (hasHoles, done) = partition ((> 0) . fst) fits
@@ -427,7 +429,7 @@ findEvaluatedHoles
427429
resolve = map $ (expr_map IntMap.!) *** map (first (eprop_map Map.!))
428430

429431
-- traces that worked are all non-empty traces that are sufficiently mapped to exprs and props
430-
traces_that_worked <-
432+
traces_that_worked :: [(EExpr, Map (EExpr, SrcSpan) Integer)] <-
431433
liftIO $
432434
map (second (Map.unionsWith (+) . map (toInvokes . snd)))
433435
-- The traces are per prop per expr, but we need a per expr per prop,
@@ -444,23 +446,33 @@ findEvaluatedHoles
444446
-- We then remove suggested holes that are unlikely to help (naively for now
445447
-- in the sense that we remove only holes which did not get evaluated at all,
446448
-- so they are definitely not going to matter).
447-
let fk (expr, invokes) | non_zero <- Map.keysSet (Map.filter (> 0) invokes),
448-
not (null non_zero) = do
449-
liftIO $ logStr DEBUG "Building trace correlation..."
450-
trace_correls_per_target <- buildTraceCorrel cc tp expr
451-
452-
let non_zero_src = Set.unions $ Set.map lookupInCorrel non_zero
453-
lookupInCorrel el =
454-
case mapMaybe (Map.lookup el) trace_correls_per_target of
455-
-- TODO: This should never happen
456-
[] -> Set.empty
457-
xs -> Set.fromList xs
458-
return $ filter ((`Set.member` non_zero_src) . fst) $ sanctifyExpr expr
459-
fk _ = return []
460-
nubOrd = Set.toList . Set.fromList
461-
non_zero_holes <- mapM fk traces_that_worked
449+
let fk :: (EExpr, Map (EExpr, SrcSpan) Integer) -> Set.Set (SrcSpan, LHsExpr GhcPs)
450+
fk (expr, invokes)
451+
| non_zero <- Map.keysSet (Map.filter (> 0) invokes),
452+
not (null non_zero) =
453+
Set.fromList $ mapMaybe toExprHole $ Set.toList non_zero
454+
where
455+
sfe = sanctifyExpr noExtField expr
456+
toExprHole (iv_expr, iv_loc) =
457+
-- We can get a Nothing here if e.g. the evaluated part is with
458+
-- an operator with precedence, e.g. a ++ b ++ c, because GHC
459+
-- doesn't do precedence until it renames. We *could* use the
460+
-- renamed `iv_expr` and rename the `expr` as well to get those
461+
-- locs... but then we'd have to switch the whole thing over to
462+
-- `LHsExpr GhcRn`, since those locs do not exsist in the
463+
-- `LHsExpr GhcPs` yet, and then we have issues with compiling
464+
-- them to get the valid hole fits, since GHC has no built-in
465+
-- function `compileRnStmt`. So we'll make do for now.
466+
case find is_iv (zip sfe sfi) of
467+
Just (e@(e_loc,_), _) | isGoodSrcSpan e_loc -> Just e
468+
_ -> Nothing
469+
where
470+
sfi = sanctifyExpr noExtField iv_expr
471+
is_iv = (== iv_loc) . fst . snd
472+
fk _ = Set.empty
473+
non_zero_holes = Set.unions $ map fk traces_that_worked
462474
-- nubOrd deduplicates collections of sortable items. it's faster than other dedups.
463-
let nzh = nubOrd $ concat non_zero_holes
475+
let nzh = Set.toList non_zero_holes
464476
liftIO $ logStr DEBUG $ "Found " ++ show (length nzh) ++ " evaluated holes"
465477
return nzh
466478
findEvaluatedHoles _ = error "Cannot find evaluated holes of external problems yet!"
@@ -865,7 +877,7 @@ describeProblem conf@Conf {compileConfig = ogcc} fp = collectStats $ do
865877
exprFitCands <- runGhc' compConf $ getExprFitCands $ Right modul
866878
let probModule = Just modul
867879
initialFixes = Nothing
868-
addConf = AddConf {assumeNoLoops = True}
880+
addConf = def {assumeNoLoops = True}
869881
descBase = ProbDesc {..}
870882
if precomputeFixes
871883
then do

‎src/Endemic/Traversals.hs

+16-7
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ import Data.List (intercalate)
3232
import Data.Map (Map, member, (!))
3333
import GHC
3434
import GhcPlugins
35+
import Data.Char (isAlphaNum, ord)
3536

3637
-- TODO: This doesn't recurse into (L _ (HsWrap _ _ v)), because there's no located expressions in v!
3738

@@ -41,15 +42,15 @@ flattenExpr = universeOf uniplate
4142

4243
-- | Replace all expressions in a given expression with those
4344
-- found in the given map.
44-
replaceExpr :: Map SrcSpan (HsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
45+
replaceExpr :: Data (HsExpr id) => Map SrcSpan (HsExpr id) -> LHsExpr id -> LHsExpr id
4546
replaceExpr repls =
4647
transformOf uniplate $ \case
4748
L loc _ | loc `member` repls -> L loc (repls ! loc)
4849
e -> e
4950

5051
-- | Replace all expressions in a given expression with those
5152
-- found in the given map.
52-
wrapExpr :: SrcSpan -> (HsExpr GhcPs -> HsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
53+
wrapExpr :: Data (HsExpr id) => SrcSpan -> (HsExpr id -> HsExpr id) -> LHsExpr id -> LHsExpr id
5354
wrapExpr repl_loc trans =
5455
transformOf uniplate $ \case
5556
L loc x | loc == repl_loc -> L loc (trans x)
@@ -59,18 +60,26 @@ wrapExpr repl_loc trans =
5960
-- the expression "holey". Which is pronounced holy.
6061
-- Could also be named `perforate`, `stigmatize` or
6162
-- `spindle`. See https://twitter.com/tritlo/status/1367202546415206400
62-
sanctifyExpr :: LHsExpr GhcPs -> [(SrcSpan, LHsExpr GhcPs)]
63-
sanctifyExpr = map repl . contextsOf uniplate
63+
sanctifyExpr :: (Data (HsExpr id), HasOccName (IdP id)) =>
64+
XUnboundVar id -> LHsExpr id -> [(SrcSpan, LHsExpr id)]
65+
sanctifyExpr ext = map repl . contextsOf uniplate
6466
where
6567
repl ctxt = (loc, peek (L loc hole) ctxt)
6668
where
6769
(L loc expr) = pos ctxt
68-
hole = HsUnboundVar noExtField $ TrueExprHole name
70+
hole = HsUnboundVar ext $ TrueExprHole name
6971
name = case expr of
7072
HsVar _ (L _ v) ->
71-
let (ns, fs) = (occNameSpace (occName v), occNameFS (occName v))
73+
let (ns, fs) = (occNameSpace (occName v), fsLit (sanitize v))
7274
in mkOccNameFS ns (concatFS $ fsLit "_" : [fs, fsLit $ locToStr loc])
7375
_ -> mkVarOcc $ "_" ++ locToStr loc
76+
sanitize nm =
77+
if not (null alphanum)
78+
then alphanum
79+
else intercalate "_" $ map (show . ord) base
80+
where
81+
base = occNameString $ occName nm
82+
alphanum = filter isAlphaNum base
7483
locToStr (UnhelpfulSpan x) = unpackFS x
7584
locToStr s@(RealSrcSpan r) =
7685
intercalate "_" $
@@ -80,7 +89,7 @@ sanctifyExpr = map repl . contextsOf uniplate
8089
++ [srcSpanEndCol r]
8190

8291
-- | Fill the first hole in the given holed-expression.
83-
fillHole :: HsExpr GhcPs -> LHsExpr GhcPs -> Maybe (SrcSpan, LHsExpr GhcPs)
92+
fillHole :: Data (HsExpr id) => HsExpr id -> LHsExpr id -> Maybe (SrcSpan, LHsExpr id)
8493
fillHole fit = fillFirst . contextsOf uniplate
8594
where
8695
fillFirst (ctxt : ctxts) =

‎src/Endemic/Types.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,7 @@ isFixed :: TestSuiteResult -> Bool
7979
isFixed (Right x) = x
8080
isFixed (Left xs) = and xs
8181

82-
type Trace = Tree (SrcSpan, [(BoxLabel, Integer)])
82+
type Trace = (LHsExpr GhcPs, Tree (SrcSpan, [(BoxLabel, Integer)]))
8383

8484
type TraceRes = [Trace]
8585

0 commit comments

Comments
 (0)