Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Fix ambiguous loopbreakers #9

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Fix ambiguous loopbreakers #9

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 1 addition & 2 deletions loopbreaker.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: b56a57a63829e80e77783f285ed80370eb48a4b37fb1c92fa74e2870f29817f2
-- hash: d119510f8f4cf364fb3685f93c9b5b4684667c45e0b103e35f11e635e2efe8cf

name: loopbreaker
version: 0.1.1.1
Expand Down Expand Up @@ -52,7 +52,6 @@ test-suite loopbreaker-test
main-is: Spec.hs
other-modules:
DisableFlagSpec
Experiments
InlineRecCallsSpec
PragmaDetectionSpec
TestUtils
Expand Down
20 changes: 12 additions & 8 deletions src/Loopbreaker/InlineRecCalls.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -85,13 +85,16 @@ inlineRecCall types inlined (Recursive, binds)
dyn_flags <- getDynFlags
liftIO $ debugTraceMsg dyn_flags 2 $ text "Loopbreaker:" <+> ppr fun_name

(loopb_name, loopb_decl) <- loopbreaker fun_name
let fun_type = M.lookup fun_name types

(loopb_name, loopb_decl) <- loopbreaker fun_name fun_type

let m_loopb_sig = loopbreakerSig loopb_name <$> fun_type

fun_matches' <- everywhereM ( fmap (replaceVarNamesT fun_name loopb_name)
. inlineLocalRecCallsM
) fun_matches

let m_loopb_sig = loopbreakerSig loopb_name <$> M.lookup fun_name types

pure
( ( Recursive
Expand All @@ -109,21 +112,22 @@ inlineRecCall _ _ binds = pure (binds, [])

------------------------------------------------------------------------------
-- | Creates loopbreaker and it's name from name of the original function.
loopbreaker :: MonadUnique m => Name -> m (Name, LHsBind GhcRn)
loopbreaker fun_name =
(id &&& loopbreakerDecl fun_name) <$> loopbreakerName fun_name
loopbreaker :: MonadUnique m
=> Name -> Maybe (LHsSigWcType GhcRn) -> m (Name, LHsBind GhcRn)
loopbreaker fun_name fun_type =
(id &&& loopbreakerDecl fun_name fun_type) <$> loopbreakerName fun_name

------------------------------------------------------------------------------
loopbreakerName :: MonadUnique m => Name -> m Name
loopbreakerName (occName -> occNameFS -> orig_fs) =
flip mkSystemVarName (orig_fs <> "__Loopbreaker") <$> getUniqueM

------------------------------------------------------------------------------
loopbreakerDecl :: Name -> Name -> LHsBind GhcRn
loopbreakerDecl fun_name loopb_name =
loopbreakerDecl :: Name -> Maybe (LHsSigWcType GhcRn) -> Name -> LHsBind GhcRn
loopbreakerDecl fun_name fun_type loopb_name =
noLoc $ mkTopFunBind Generated (noLoc loopb_name)
[ mkSimpleMatch (mkPrefixFunRhs $ noLoc loopb_name) [] $
nlHsVar fun_name
maybe id (fmap noLoc . ExprWithTySig) fun_type $ nlHsVar fun_name
]

------------------------------------------------------------------------------
Expand Down