diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -9,44 +9,81 @@ import Paths_hermit as P import Data.Version +import Data.List (isPrefixOf) +import System.Directory (doesFileExist) + hermit_version :: String hermit_version = "HERMIT v" ++ showVersion P.version +usage :: IO () +usage = putStrLn $ unlines + [hermit_version + ,"" + ,"usage: hermit File.hs SCRIPTNAME" + ," - OR -" + ," hermit File.hs [HERMIT_ARGS] [+module_name [MOD_ARGS]]* [-- [ghc-args]]" + ,"" + ,"examples: hermit Foo.hs Foo.hss" + ," hermit Foo.hs -p6 +main:Main Foo.hss" + ," hermit Foo.hs +main:Main Foo.hss resume" + ," hermit Foo.hs +main:Main Foo.hss +other:Other Bar.hss" + ," hermit Foo.hs -- -ddump-simpl -ddump-to-file" + ,"" + ,"If a module name is not supplied, the module main:Main is assumed." + ,"" + ,"HERMIT_ARGS" + ," -pN : where 0 <= N < 18 is the position in the pipeline in which HERMIT should run, 0 being at the beginning" + ,"" + ,"MOD_ARGS" + ," SCRIPTNAME : name of script file to run for this module" + ," resume : skip interactive mode and resume compilation after any scripts" + ] + main :: IO () main = do args <- getArgs - main2 args + main1 args -main2 :: [String] -> IO () -main2 [] = putStrLn $ unlines - [hermit_version - ,"" - ,"usage: hermit .hs [args] [-- [ghc-args]]" - ] -main2 (mod_nm:args) = case span (/= "--") args of - (hermit_args,"--":ghc_args) -> main3 mod_nm hermit_args ghc_args - (hermit_args,[]) -> main3 mod_nm hermit_args [] +main1 :: [String] -> IO () +main1 [] = usage +main1 [file_nm,script_nm] = do + e <- doesFileExist script_nm + if e then main4 file_nm [] [("main:Main", [script_nm])] [] else usage +main1 other = main2 other + +main2 (file_nm:rest) = case span (/= "--") rest of + (args,"--":ghc_args) -> main3 file_nm args ghc_args + (args,[]) -> main3 file_nm args [] _ -> error "hermit internal error" -main3 mod_nm hermit_args ghc_args = do - putStrLn $ "[starting " ++ hermit_version ++ " on " ++ mod_nm ++ "]" +main3 file_nm args ghc_args = main4 file_nm hermit_args (sepMods margs) ghc_args + where (hermit_args, margs) = span (not . isPrefixOf "+") args + + sepMods :: [String] -> [(String, [String])] + sepMods [] = [] + sepMods (('+':mod_nm):rest) = (mod_nm, mod_opts) : sepMods next + where (mod_opts, next) = span (not . isPrefixOf "+") rest + +main4 file_nm hermit_args [] ghc_args = main4 file_nm hermit_args [("main:Main", [])] ghc_args +main4 file_nm hermit_args module_args ghc_args = do + putStrLn $ "[starting " ++ hermit_version ++ " on " ++ file_nm ++ "]" let cmds = - [ mod_nm + [ file_nm , "-fforce-recomp" , "-O2" , "-dcore-lint" , "-fsimple-list-literals" -- , "-v0" - , "-fplugin=HERMIT" - ] ++ [ "-fplugin-opt=HERMIT:main:Main:" ++ opt - | opt <- "" : hermit_args - ] ++ ghc_args + , "-fplugin=HERMIT" + ] ++ + [ "-fplugin-opt=HERMIT:" ++ opt + | opt <- hermit_args + ] ++ + [ "-fplugin-opt=HERMIT:" ++ m_nm ++ ":" ++ opt + | (m_nm, m_opts) <- module_args + , opt <- "" : m_opts + ] ++ ghc_args putStrLn $ "% ghc " ++ unwords cmds (_,_,_,r) <- createProcess $ proc "ghc" cmds ex <- waitForProcess r exitWith ex - - - - - diff --git a/examples/WWSplitTactic.hss b/examples/WWSplitTactic.hss new file mode 100644 --- /dev/null +++ b/examples/WWSplitTactic.hss @@ -0,0 +1,18 @@ +{ +fix-intro +consider lam +let-intro 'f +up +let-float-arg +1 +apply-rule ww +simplify +{ 1; let-intro 'w } +let-float-arg +{ rhs-of 'w + unfold 'fix ; alpha-let 'work + simplify +} +let-subst +let-float-arg +} diff --git a/examples/concatVanishes/ConcatVanishes.hss b/examples/concatVanishes/ConcatVanishes.hss --- a/examples/concatVanishes/ConcatVanishes.hss +++ b/examples/concatVanishes/ConcatVanishes.hss @@ -1,3 +1,4 @@ +flatten-module consider let { consider def ; fix-intro } safe-let-subst @@ -12,4 +13,3 @@ bash any-call (unfold 'absH) try unshadow - diff --git a/examples/concatVanishes/Makefile b/examples/concatVanishes/Makefile deleted file mode 100644 --- a/examples/concatVanishes/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -HERMIT = hermit - -rev: - $(HERMIT) Rev.hs Rev.hss - -flatten: - $(HERMIT) Flatten.hs Flatten.hss - -qsort: - $(HERMIT) QSort.hs QSort.hss diff --git a/examples/contents.txt b/examples/contents.txt deleted file mode 100644 --- a/examples/contents.txt +++ /dev/null @@ -1,181 +0,0 @@ -Concatenate Vanishes -==================== - -* A common script for all our Concatenate Vanishes examples. - -* Completed. - -* Interesting rewrites: push, innermost, unfold-rule - -* It works for all three examples, but I doubt it would work for *any* concat vanishes example. - -* Notes: unsafe uses of RULES with pre-conditions. - - -Evaluation -========== - -* Evaluation of Hutton's Razor with exceptions. - -* Convert to CPS to avoid repeated pattern matching. - -* Completed. - -* Interesting rewrites: abstract, fold - - -Fibonacci (Tupling) -=================== - -* Example of Tupling transformation. - -* Completed and published - -* Interesting rewrites: ww-split tactic, case-split(-inline), fold, remember (and fold/unfold remembered defns), let-tuple - - -Fibonacci (Stream Memoisation) -=================== - -* Example of Memoisation. - -* Completed. - -* Interesting rewrites: ww-split tactic - - -Flatten -======= - -* Another concatenate-vanishes example, based on the Reverse example. - -* Completed. - -* Main rewrites: any-call - - -Hanoi -===== - -* Another tupling transformation - -* Completed. - -* Interesting rewrites: ww-split tactic, case-split(-inline), fold, remember (and fold/unfold remembered defns), let-tuple - -Map -=== - -* List unrolling. - -* Completed. - -* Main rewrites: simplify, any-call, unfold, case-split(-inline), remember. - - -Haskell 2012 Paper -================== - -Fibonacci (Unrolling) ---------------------- - -* We unfold fib once to show how things operate overall. - -* Main rewrites: any-bu, inline - - -Reverse -------- - -* Our larger, low-level reverse example. - -* Main rewrites: any-bu, unfold - - -Append ------- - -* A demonstration of GHC RULES (no use of HERMIT). - - -IFL 2012 Paper -================== - -Fibonacci (Tupling) -------------------- - -* Example of Tupling transformation. - -* Interesting rewrites: ww-split tactic, case-split(-inline), fold, remember (fold/unfold remembered defns), let-tuple - - -Last -==== - -* A classic simple example. - -* Completed. - - -Mean -==== - -* Problem (and pen-and-paper calculation) provided by Jason Reich. - -* A non-WW tupling example (maybe it can be cast as WW, I'm not sure). - -* Completed. - -* Interesting rewrites: abstract, remember, fold, let-intro, let-float, let-tuple - - - -Nub -=== - -* A new (that is, unpublished) worker/wrapper example. - -* There was a bug in Andy's original pen-and-paper derivation. - -* A corrected version is in the files named "Revised". - -* There has been no attempt to mechanise this revised derivation as yet. - - - -Quicksort -========= - -* Another concatenate-vanishes example. - -* Completed. - -* Main rewrites: any-call - - -Reverse -======= - -* Higher-level script than in the Haskell 2012 paper. - -* Completed. Lower-level version has been published. - -* Main rewrites: any-call - - -Talks -===== - -* This directory is for the code that Neil intends to demo at Nottingham, IFL and Haskell. - -* Don't mess with it without telling him! - - -To Do -===== - -* Life - Can we translate to a stronger type? - -* Kansas Lava example? - - diff --git a/examples/evaluation/Eval.hs b/examples/evaluation/Eval.hs new file mode 100644 --- /dev/null +++ b/examples/evaluation/Eval.hs @@ -0,0 +1,33 @@ +module Main where + +import Data.Function(fix) + +data Expr = Val Int | Add Expr Expr | Throw | Catch Expr Expr + +type Mint = Maybe Int + +eval :: Expr -> Mint +eval (Val n) = Just n +eval Throw = Nothing +eval (Catch x y) = case eval x of + Nothing -> eval y + Just n -> Just n +eval (Add x y) = case eval x of + Nothing -> Nothing + Just m -> case eval y of + Nothing -> Nothing + Just n -> Just (m + n) + +unwrap :: (Expr -> Mint) -> Expr -> (Int -> Mint) -> Mint -> Mint +unwrap g e s f = case g e of + Nothing -> f + Just n -> s n + +wrap :: (Expr -> (Int -> Mint) -> Mint -> Mint) -> Expr -> Mint +wrap h e = h e Just Nothing + +{-# RULES "ww" forall f. fix f = wrap (fix (unwrap . f . wrap)) #-} +{-# RULES "fusion" forall w. unwrap (wrap w) = w #-} -- has precondition + +main :: IO () +main = print (eval $ Val 5) diff --git a/examples/evaluation/Eval.hss b/examples/evaluation/Eval.hss new file mode 100644 --- /dev/null +++ b/examples/evaluation/Eval.hss @@ -0,0 +1,19 @@ +flatten-module +consider 'eval +load "../WWSplitTactic.hss" +{rhs-of 'work + eta-expand 'e ; 0 + eta-expand 's ; 0 + eta-expand 'f ; 0 + unfold 'unwrap + one-td (unfold 'f) + bash + { + consider case ; 2 ; 0 ; abstract 'm + consider case ; 2 ; 0 ; abstract 'n + } + any-bu (fold 'unwrap) + any-bu (unfold-rule "fusion") +} +simplify +any-call (unfold 'wrap) diff --git a/examples/factorial/Fac.hs b/examples/factorial/Fac.hs new file mode 100644 --- /dev/null +++ b/examples/factorial/Fac.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE MagicHash #-} + +import Prelude hiding ((*),(-)) +import GHC.Exts +import Data.Function(fix) + +fac :: Int -> Int +fac 0 = 1 +fac n = n * fac (n -1) + +unwrap :: (Int -> Int) -> Int# -> Int# +unwrap h x = case h (I# x) of + I# y -> y + +wrap :: (Int# -> Int#) -> Int -> Int +wrap h (I# x) = I# (h x) + +{-# RULES "ww" forall f. fix f = wrap (fix (unwrap . f . wrap)) #-} + +main :: IO () +main = print (fac 10) + + +(*) :: Int -> Int -> Int +(I# x) * (I# y) = I# (x *# y) + +(-) :: Int -> Int -> Int +(I# x) - (I# y) = I# (x -# y) diff --git a/examples/factorial/Fac.hss b/examples/factorial/Fac.hss new file mode 100644 --- /dev/null +++ b/examples/factorial/Fac.hss @@ -0,0 +1,20 @@ +flatten-module +consider 'fac +load "../WWSplitTactic.hss" +{rhs-of 'work + eta-expand 'x + one-td (unfold 'unwrap) + one-td (unfold 'f) + one-td (unfold 'wrap) + simplify + { + consider alt ; 0 ; case-float-arg + consider alt ; 0 ; case-float-arg + } + one-td (unfold '-) + one-td (unfold '*) + simplify + innermost case-float-case +} +simplify +{ consider let ; 1 ; eta-expand 'n ; any-call (unfold 'wrap) } diff --git a/examples/fib-stream/Fib.hss b/examples/fib-stream/Fib.hss --- a/examples/fib-stream/Fib.hss +++ b/examples/fib-stream/Fib.hss @@ -1,14 +1,12 @@ flatten-module consider 'fib { -load "WWSplitTactic.hss" -{ 0 ; 1 - { 0 - any-call (unfold 'unwrap) + load "../WWSplitTactic.hss" + {rhs-of 'work + unfold 'unwrap any-call (unfold 'f) { consider lam ; alpha-lam 'm } } -} -innermost dead-code-elimination -any-call (unfold 'wrap) + simplify + any-call (unfold 'wrap) } diff --git a/examples/fib-stream/Makefile b/examples/fib-stream/Makefile deleted file mode 100644 --- a/examples/fib-stream/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -HERMIT = perl ../../scripts/hermit.pl - -fib: - - $(HERMIT) Fib.hs Fib.hss resume - -interactive: - - $(HERMIT) Fib.hs Fib.hss - -start: - - $(HERMIT) Fib.hs diff --git a/examples/fib-stream/WWSplitTactic.hss b/examples/fib-stream/WWSplitTactic.hss deleted file mode 100644 --- a/examples/fib-stream/WWSplitTactic.hss +++ /dev/null @@ -1,18 +0,0 @@ -{ -fix-intro -consider lam -let-intro 'f -up -let-float-arg -1 -apply-rule ww -simplify -{ 1; let-intro 'w } -let-float-arg -{ rhs-of 'w - unfold 'fix ; alpha-let 'work - simplify -} -let-subst -let-float-arg -} diff --git a/examples/fib-tuple/Fib.hss b/examples/fib-tuple/Fib.hss --- a/examples/fib-tuple/Fib.hss +++ b/examples/fib-tuple/Fib.hss @@ -3,7 +3,7 @@ { -load "WWSplitTactic.hss" +load "../WWSplitTactic.hss" consider 'work ; remember origwork -- work = unwrap (f (wrap work)) @@ -22,13 +22,13 @@ -- work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2)) { 1 ; any-call (unfold 'f) } -{ 2 ; 0 ; 1 ; any-bu (unfold 'f) } +{ 2 ; 0 ; 1 ; any-call (unfold 'f) } simplify -- work 0 = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n) -2 ; 0 ; { 1 ; any-bu (unfold origwork) } +2 ; 0 ; { 1 ; any-call (unfold origwork) } -- work 0 = (0, 1) -- work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n) @@ -59,5 +59,7 @@ } -innermost dead-code-elimination -{ 0 ; 1 ; any-call (unfold 'wrap) ; simplify } +innermost dead-let-elimination +any-call (unfold 'wrap) +simplify + diff --git a/examples/fib-tuple/Makefile b/examples/fib-tuple/Makefile deleted file mode 100644 --- a/examples/fib-tuple/Makefile +++ /dev/null @@ -1,19 +0,0 @@ -HERMIT = perl ../../scripts/hermit.pl - -fib: - - $(HERMIT) Fib.hs Fib.hss resume - -interactive: - - $(HERMIT) Fib.hs Fib.hss - -start: - - $(HERMIT) Fib.hs - -test: - - rm *.o *.hi Fib - - ghc --make -O2 -o Fib -fforce-recomp Fib.hs - - ./Fib > timing.txt - - echo "===========================================" >> timing.txt - - $(HERMIT) Fib.hs Fib.hss resume - - ./Fib >> timing.txt - - cat timing.txt diff --git a/examples/fib-tuple/WWSplitTactic.hss b/examples/fib-tuple/WWSplitTactic.hss deleted file mode 100644 --- a/examples/fib-tuple/WWSplitTactic.hss +++ /dev/null @@ -1,51 +0,0 @@ --- this is a (pretty general) ww tactic --- it transforms: --- --- rec g = body (where body mentions g) --- --- into: --- --- g = let f = \g -> body (f is not recursive) --- rec work = unwrap (f (wrap work)) --- in wrap work --- --- Note: inlining f (and bashing) would result in the same code --- achieved in the reverse example by applying the "ww" rule. --- --- The original function g is now a non-recursive wrapping of the worker. --- The worker makes use of the original body, and is recursive. --- --- So what have we gained doing it this way? Mainly, the noise of the --- original body is all tidily hidden in f, and we can focus on manipulating --- the wrap and unwrap functions, which is what we want to do. --- --- I've tested this on reverse, and it also works, so I think the --- next step is to formulate it as an actual rewrite, or otherwise --- bundle it up as a one-liner. --- --- TODO: this relies on a RULES pragmas: --- --- {-# RULES "ww" forall work . fix work = wrap (fix (unwrap . work . wrap)) #-} --- --- We either need to provide this somehow, or implement it as a rewrite. --- --- BEGIN: ww tactic -{ -fix-intro -consider lam -let-intro 'f -up -let-float-arg -1 -apply-rule ww -simplify -{ 1; let-intro 'w } -let-float-arg -{ rhs-of 'w - unfold 'fix ; alpha-let 'work - simplify -} -let-subst -let-float-arg -} --- END: ww tactic diff --git a/examples/fib-tuple/blog.txt b/examples/fib-tuple/blog.txt deleted file mode 100644 --- a/examples/fib-tuple/blog.txt +++ /dev/null @@ -1,195 +0,0 @@ -Using this file to keep track of progress/improvements coming out of this example. -Format: steps from Neil's worker/wrapper derivation with interspersed commentary. -Entire derivation is: - --- Normal fib definition -fib :: Nat -> Nat -fib = body - --- After WWSplit tactic -fib = wrap work - -f :: (Nat -> Nat) -> Nat -> Nat -f = \fib -> body - -wrap :: (Nat -> (Nat, Nat)) -> (Nat -> Nat) -unwrap :: (Nat -> Nat) -> (Nat -> (Nat, Nat)) -work :: Nat -> (Nat, Nat) - --- Derivation -work = unwrap (f (wrap work)) - {- extensionality -} -work n = unwrap (f (wrap work)) n - {- unfold 'unwrap -} -work n = (f (wrap work) n, f (wrap work) (n+1)) - {- case 'n -} -work 0 = (f (wrap work) 0, f (wrap work) 1) -work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2)) - {- unfold 'f -} -work 0 = (0, 1) -work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n) - {- unfold 'work -} -work 0 = (0, 1) -work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n) - {- wrap . unwrap = id (precondition) -} -work 0 = (0, 1) -work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n) - {- let-intro x2, let-float-tuple -} -work 0 = (0, 1) -work (n+1) = let (x,y) = (f (wrap work) n, f (wrap work) (n+1)) in (y,x+y) - {- fold 'unwrap -} -work 0 = (0, 1) -work (n+1) = let (x,y) = unwrap (f (wrap work)) n in (y,x+y) - {- fold 'work -} -work 0 = (0, 1) -work (n+1) = let (x,y) = work n in (y,x+y) - {- QED -} - -Discussion: - -############################################################################### - -work = unwrap (f (wrap work)) - -To get to this point required creation of the WWSplit tactic. This -is slightly more complicated than how we did the split in the reverse -example in the paper, because we want to keep f abstract for most -of this derivation (we selectively unfold it once). I was able to -create a tactic which I believe is entirely general, allowing one -to rewrite: - - letrec g = body - -to: - - let g = (let f = \g -> body - in (letrec work = unwrap (f (wrap work)) - in wrap work)) - -There are a couple todo's regarding this split. It relies on -two GHC RULES pragmas (ww, and inline-fix). These should probably -be written as rewrites. Doing so would probably allow the whole -tactic to be expressed as a rewrite, rather than a hermit script. - -############################################################################### - - {- extensionality -} -work n = unwrap (f (wrap work)) n - -This was done with "eta-expand 'n". Allowing core lint to run revealed -that eta-expand was not handling types correctly. This is fixed in commit -b49fcd2be2ff0592ab51a2e9b8a291dff48bbf4b by using splitFunTy_maybe, which -looks to be a really handy function. Must remember to exit Hermit with -resume, instead of abort, so core-lint runs. - -############################################################################### - - {- unfold 'unwrap -} -work n = (f (wrap work) n, f (wrap work) (n+1)) - -At the moment we have to be careful to call unfold at the right place. Otherwise -we end up with extra redexes that must be dealt with. - -############################################################################### - - {- case 'n -} -work 0 = (f (wrap work) 0, f (wrap work) 1) -work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+2)) - -This step required two new capabilites: - - * A case-split rewrite that accepts the name of a free variable of an - expression, finds all the data constructors belonging to the type, - and builds a case statement, cloning the expression for each case alt. - Getting the correct types of the pattern binders was tricky (or simple - once I found the correct GHC functions to instantiate the constructor - argument types). - - * Modify the Hermit context to store two possible values for variables - that are case wildcard binders. These can refer to either the scrutinee - (previous behavior), or the constructor application of the pattern. This - is what allows the 'n above to be replaced by 0 and 1 when case splitting. - It is important to store the AltCon and binders in the context, and only - convert to a CoreExpr upon inlining, so that we can apply the constructor - at the correct types. - -There is a case-split-inline rewrite that combines these steps. This step -also required rewriting fib to work over: - - data Nat = Zero | Succ Nat - -rather than Int, as the only Int constructor is the one which boxes Int#. We -probably need an case-literal rewrite, which accepts a literal and adds a -LitCon pattern. We could then go back to working on Int, and "case-literal 0" -rather than "case-split-inline 'n". - -############################################################################### - - {- unfold 'f -} -work 0 = (0, 1) -work (n+1) = (f (wrap work) (n+1), wrap work (n+1) + wrap work n) - -This step is done by calling unfold and repeatedly applying case-reduce on -three of the four tupled expressions. Should we add case-reduce to the -unfold cleanup step? Is there a more general cleanup rewrite we can build -that isn't as invasive as bash, but handles this stuff for us? I can imagine -some rewrites (like case-reduce) that we simply always want to run, as they -are effectively dead code elimination. - -############################################################################### - - {- unfold 'work -} -work 0 = (0, 1) -work (n+1) = (f (wrap work) (n+1), wrap (unwrap (f (wrap work))) (n+1) + wrap (unwrap (f (wrap work))) n) - -Our first run-in with equational reasoning issues. The problem is that we -want to unfold the definition of work we started with, not the one we currently -have. We are experimenting with two approaches to this: - - 1. Create a GHC rule on the fly, stash it in the ModGuts, and then - use unfold-rule. There are (currently) a few problems with this: - - * Only top-level bindings consistently work as rules. This can probably - be solved by tracking down the occasional kernel panic. See my email - on July 12th about the issue. - - * The add-rule rewrite works on ModGuts (by necessity), so you must be - at the top level to use it. This is problematic when inside scoping - braces, which prevent you from going up by design. - - 2. Stash the definition in the HermitMonad (currently) or alongside the - AST in the kernel. This is the method I'm currently using in the - derivation. It appears to work quite well, and gives us control - over how its unfolded. We can reject unfoldings that would result - in variables that are not defined (because a binding is no longer - present), for instance. TODO: prevent unintended capture! - -The two rewrites added for #2 are: - - stashDef :: String -> TranslateH CoreDef () -- stashes the RHS of binding, with a name - -- stash-defn - stashApply :: String -> RewriteH CoreExpr -- like inline, but looks up a stashed name - -- stash-apply - -############################################################################### - - {- wrap . unwrap = id (precondition) -} -work 0 = (0, 1) -work (n+1) = (f (wrap work) (n+1), f (wrap work) (n+1) + f (wrap work) n) - -I'm currently using a GHC rule for this: - - {-# RULES precondition forall w . wrap (unwrap w) = w #-} - -############################################################################### - - {- let-intro x2, let-float -} -work 0 = (0, 1) -work (n+1) = let (x,y) = (f (wrap work) n, f (wrap work) (n+1)) in (y,x+y) - {- fold 'unwrap -} -work 0 = (0, 1) -work (n+1) = let (x,y) = unwrap (f (wrap work)) n in (y,x+y) - {- fold 'work -} -work 0 = (0, 1) -work (n+1) = let (x,y) = work n in (y,x+y) - {- QED -} diff --git a/examples/flatten/Flatten.hs b/examples/flatten/Flatten.hs new file mode 100644 --- /dev/null +++ b/examples/flatten/Flatten.hs @@ -0,0 +1,25 @@ +module Main where + +import HList +import Data.Function (fix) + +data Tree a = Node (Tree a) (Tree a) | Leaf a + +{-# INLINE unwrap #-} +unwrap :: (Tree a -> [a]) -> (Tree a -> H a) +unwrap f = repH . f + +{-# INLINE wrap #-} +wrap :: (Tree a -> H a) -> (Tree a -> [a]) +wrap g = absH . g + +{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-} +{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-} + +-- flatten :: Tree a -> [a] +flatten (Leaf a) = [a] +flatten (Node l r) = flatten l ++ flatten r + +main :: IO () +main = print (flatten (Node (Leaf 'h') (Leaf 'i'))) + diff --git a/examples/flatten/Flatten.hss b/examples/flatten/Flatten.hss new file mode 100644 --- /dev/null +++ b/examples/flatten/Flatten.hss @@ -0,0 +1,37 @@ +flatten-module +consider 'flatten +{ + consider 'flatten + fix-intro + 0 + unfold-rule "ww" + any-call (unfold '.) + any-call (unfold 'wrap) + any-call (unfold 'unwrap) + any-call (unfold '.) + bash + unshadow + any-bu case-float-arg + { + consider case + any-bu (apply-rule "repH ++") + bash + any-bu (unfold-rule "rep-abs-fusion") + { + 2 + 0 + unfold-rule "repH (:)" + one-td (unfold-rule "repH []") + unfold-rule "(.) id" + } + } + { + consider app + unfold 'fix + alpha-let 'work + } +} +bash +try unshadow +one-td (unfold 'absH) + diff --git a/examples/flatten/HList.hs b/examples/flatten/HList.hs new file mode 100644 --- /dev/null +++ b/examples/flatten/HList.hs @@ -0,0 +1,39 @@ +module HList + ( H + , repH + , absH + ) where + +type H a = [a] -> [a] + +{-# INLINE repH #-} +repH :: [a] -> H a +repH xs = (xs ++) + +{-# INLINE absH #-} +absH :: H a -> [a] +absH f = f [] + +-- These two we may get for free via INLINE +{-# RULES "repH" forall xs . repH xs = (xs ++) #-} +{-# RULES "absH" forall f . absH f = f [] #-} + +-- The "Algebra" for repH +{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} +{-# RULES "repH []" repH [] = id #-} +{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} + +-- Should be in the "List" module +{-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-} +{-# RULES "[] ++" forall xs . [] ++ xs = xs #-} + +-- Should be somewhere else +{-# RULES "(.) id" forall f . f . id = f #-} + +-- has preconditon +{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-} + + + + + diff --git a/examples/hanoi/Hanoi.hss b/examples/hanoi/Hanoi.hss --- a/examples/hanoi/Hanoi.hss +++ b/examples/hanoi/Hanoi.hss @@ -2,7 +2,7 @@ -- do the w/w split consider 'hanoi -{ load "../fib-tuple/WWSplitTactic.hss" } +{ load "../WWSplitTactic.hss" } { consider 'work remember origwork @@ -56,4 +56,4 @@ } } } -innermost dead-code-elimination +innermost dead-let-elimination diff --git a/examples/hanoi/Makefile b/examples/hanoi/Makefile deleted file mode 100644 --- a/examples/hanoi/Makefile +++ /dev/null @@ -1,13 +0,0 @@ -hanoi: - - hermit Hanoi.hs Hanoi.hss resume - -interactive: - - hermit Hanoi.hs Hanoi.hss - -test: - - rm Hanoi *.o *.hi - - ghc --make Hanoi.hs -O2 -o Hanoi - - ./Hanoi - - rm Hanoi *.o *.hi - - hermit Hanoi.hs Hanoi.hss resume - - ./Hanoi diff --git a/examples/last/Last.hs b/examples/last/Last.hs new file mode 100644 --- /dev/null +++ b/examples/last/Last.hs @@ -0,0 +1,21 @@ +module Main where + +import Data.Function(fix) +import Prelude hiding (last) + +unwrap :: ([a] -> a) -> a -> [a] -> a +unwrap f a as = f (a:as) + +wrap :: (a -> [a] -> a) -> [a] -> a +wrap f [] = error "wrap _ []" +wrap f (a:as) = f a as + +{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-} + +-- last :: [a] -> a +last [] = error "last []" +last [a] = a +last (_:a:as) = last (a:as) + +main :: IO () +main = print (last "hello") diff --git a/examples/last/Last.hss b/examples/last/Last.hss new file mode 100644 --- /dev/null +++ b/examples/last/Last.hss @@ -0,0 +1,20 @@ +flatten-module +consider 'last +{consider 'last + load "../WWSplitTactic.hss" + {rhs-of 'work + eta-expand 'b + 0 + eta-expand 'bs + 0 + unfold 'unwrap + unfold 'f + case-reduce + consider app + unfold 'wrap + case-reduce + } +} +simplify +any-call (unfold 'wrap) + diff --git a/examples/map/Makefile b/examples/map/Makefile deleted file mode 100644 --- a/examples/map/Makefile +++ /dev/null @@ -1,10 +0,0 @@ -HERMIT = perl ../../scripts/hermit.pl - -last: - - $(HERMIT) Map.hs Map.hss resume - -interactive: - - $(HERMIT) Map.hs Map.hss - -start: - - $(HERMIT) Map.hs diff --git a/examples/map/Map.hs b/examples/map/Map.hs deleted file mode 100644 --- a/examples/map/Map.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Main where - -import Data.Function(fix) -import Prelude hiding (abs, map) - -data List2 a = Cons2 a a (List2 a) - | Singleton a - | Nil - -rep :: [a] -> List2 a -rep [] = Nil -rep [x] = Singleton x -rep (x:y:xs) = Cons2 x y (rep xs) - -abs :: List2 a -> [a] -abs Nil = [] -abs (Singleton x) = [x] -abs (Cons2 x y xs) = x : y : abs xs - -unwrap :: ([a] -> [b]) -> (List2 a -> List2 b) -unwrap f = rep . f . abs - -wrap :: (List2 a -> List2 b) -> ([a] -> [b]) -wrap f = abs . f . rep - --- needed for WWSplitTactic.hss -{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-} -{-# RULES "inline-fix" forall f . fix f = let work = f work in work #-} -{-# RULES "precondition1" forall xs . abs (rep xs) = xs #-} -{-# RULES "precondition2" forall xs . rep (abs xs) = xs #-} - --- can apply "ww" rule to this -mapPlus1Int :: [Int] -> [Int] -mapPlus1Int [] = [] -mapPlus1Int (x:xs) = (x+1) : mapPlus1Int xs - -{- can't apply "ww" rule to either of these... is it because of the forall type? -unwrap :: ((a -> b) -> [a] -> [b]) -> ((a -> b) -> [a] -> List2 b) -unwrap g f = rep . g f - -wrap :: ((a -> b) -> [a] -> List2 b) -> ((a -> b) -> [a] -> [b]) -wrap g f = abs . g f --} -mapPlus1 :: Num a => [a] -> [a] -mapPlus1 [] = [] -mapPlus1 (x:xs) = (x+1) : mapPlus1 xs - -map :: (a -> b) -> [a] -> [b] -map _ [] = [] -map f (x:xs) = f x : map f xs - -main :: IO () -main = print (map (+1) [1..10::Int]) diff --git a/examples/map/Map.hss b/examples/map/Map.hss deleted file mode 100644 --- a/examples/map/Map.hss +++ /dev/null @@ -1,47 +0,0 @@ -flatten-module -consider 'mapPlus1Int -{load "../fib-tuple/WWSplitTactic.hss" - consider 'work - - remember origwork - 0 - one-td (unfold 'unwrap) - any-call (unfold '.) - innermost (beta-reduce <+ safe-let-subst) - 0 - case-split-inline 'x - { 3 -- Nil case - any-call (unfold 'abs) - any-call (unfold 'f) - any-call (unfold 'rep) - simplify - } - { 2 -- Singleton case - any-call (unfold 'abs) - any-call (unfold 'f) - any-call (unfold 'wrap) - any-call (unfold 'rep) - -- here we make use of the already solved Nil case - any-call (unfold 'work) - simplify - any-call (unfold 'abs) - simplify - } - { 1 -- Cons2 case - any-call (unfold 'abs) - any-call (unfold 'f) - any-call (unfold 'wrap) - simplify - any-bu (unfold origwork) - any-call (unfold 'unwrap) - simplify - innermost (unfold-rule precondition1) - any-call (unfold 'f) - innermost case-reduce - any-call (unfold 'rep) - innermost case-reduce - any-call (unfold 'wrap) - simplify - innermost (unfold-rule precondition2) - } -} diff --git a/examples/mean/Mean.hs b/examples/mean/Mean.hs new file mode 100644 --- /dev/null +++ b/examples/mean/Mean.hs @@ -0,0 +1,20 @@ +import Prelude hiding (sum, length) + +-- so we can let-tuple +import Data.Tuple +import GHC.Tuple + +{-# NOINLINE mean #-} +mean :: [Int] -> Int +mean xs = sum xs `div` length xs + +sum :: [Int] -> Int +sum [] = 0 +sum (x:xs) = x + sum xs + +length :: [Int] -> Int +length [] = 0 +length (x:xs) = 1 + length xs + +main :: IO () +main = print $ mean [1..10] diff --git a/examples/mean/Mean.hss b/examples/mean/Mean.hss new file mode 100644 --- /dev/null +++ b/examples/mean/Mean.hss @@ -0,0 +1,24 @@ +{rhs-of 'mean ; 0 + { 1 ; let-intro 'l } + { 0 ; 1 ; let-intro 's } + innermost let-float + let-tuple 'sl + { 0 ; abstract 'xs ; 0 ; let-intro 'sumlength } +} +innermost let-float +consider 'sumlength +nonrec-to-rec -- since we intend sumlength to be a recursive function +0 +remember sumlen +{ 0 ; 0 + case-split-inline 'xs + any-call (unfold 'sum) + any-call (unfold 'length) + simplify + 2 ; 0 + { 1 ; 1 ; let-intro 'l } + { 0 ; 1 ; 1 ; let-intro 's } + innermost let-float + let-tuple 'sl + { 0 ; fold sumlen } +} diff --git a/examples/qsort/HList.hs b/examples/qsort/HList.hs new file mode 100644 --- /dev/null +++ b/examples/qsort/HList.hs @@ -0,0 +1,39 @@ +module HList + ( H + , repH + , absH + ) where + +type H a = [a] -> [a] + +{-# INLINE repH #-} +repH :: [a] -> H a +repH xs = (xs ++) + +{-# INLINE absH #-} +absH :: H a -> [a] +absH f = f [] + +-- These two we may get for free via INLINE +{-# RULES "repH" forall xs . repH xs = (xs ++) #-} +{-# RULES "absH" forall f . absH f = f [] #-} + +-- The "Algebra" for repH +{-# RULES "repH ++" forall xs ys . repH (xs ++ ys) = repH xs . repH ys #-} +{-# RULES "repH []" repH [] = id #-} +{-# RULES "repH (:)" forall x xs . repH (x:xs) = ((:) x) . repH xs #-} + +-- Should be in the "List" module +{-# RULES "(:) ++" forall x xs ys . (x:xs) ++ ys = x : (xs ++ ys) #-} +{-# RULES "[] ++" forall xs . [] ++ xs = xs #-} + +-- Should be somewhere else +{-# RULES "(.) id" forall f . f . id = f #-} + +-- has preconditon +{-# RULES "rep-abs-fusion" forall h . repH (absH h) = h #-} + + + + + diff --git a/examples/qsort/QSort.hs b/examples/qsort/QSort.hs new file mode 100644 --- /dev/null +++ b/examples/qsort/QSort.hs @@ -0,0 +1,28 @@ +module Main where + +import HList +import Data.Function (fix) +import Data.List + +data Tree a = Node (Tree a) (Tree a) | Leaf a + +{-# INLINE unwrap #-} +unwrap :: ([a] -> [a]) -> ([a] -> H a) +unwrap f = repH . f + +{-# INLINE wrap #-} +wrap :: ([a] -> H a) -> ([a] -> [a]) +wrap g = absH . g + +{-# RULES "ww" forall f . fix f = wrap (fix (unwrap . f . wrap)) #-} +{-# RULES "inline-fix" forall f . fix f = let w = f w in w #-} + +-- qsort :: Ord a => [a] -> [a] +qsort [] = [] +qsort (a:as) = qsort bs ++ [a] ++ qsort cs + where + (bs , cs) = partition (< a) as + +main :: IO () +main = print (qsort [8,3,5,7,2,9,4,6,3,2]) + diff --git a/examples/qsort/QSort.hss b/examples/qsort/QSort.hss new file mode 100644 --- /dev/null +++ b/examples/qsort/QSort.hss @@ -0,0 +1,36 @@ +flatten-module +consider 'qsort +{ + consider 'qsort + fix-intro + 0 + unfold-rule "ww" + any-call (unfold '.) + any-call (unfold 'wrap) + any-call (unfold 'unwrap) + any-call (unfold '.) + bash + any-td case-float-arg + bash + { + consider case + any-td (unfold-rule "repH ++") + any-td (unfold-rule "rep-abs-fusion") + any-td (unfold-rule "repH (:)") + any-td (unfold-rule "repH []") + any-call (unfold '.) + bash + { consider let + repeat let-subst -- maybe if we folded the (.) then safe-let-subst would fire and this would be unneccassary + } + any-td (unfold-rule "(.) id") + } +} +{ + consider app + unfold 'fix + alpha-let 'work +} +bash +one-td (unfold 'absH) + diff --git a/examples/reverse/Makefile b/examples/reverse/Makefile deleted file mode 100644 --- a/examples/reverse/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -HERMIT = perl ../../scripts/hermit.pl -MODULE=Reverse - -test-example: - - $(HERMIT) $(MODULE).hs resume - ./$(MODULE) - - - $(HERMIT) $(MODULE).hs $(MODULE).hss resume - ./$(MODULE) - -interactive-example: - - $(HERMIT) Reverse.hs - - diff --git a/examples/reverse/ReverseWW.hss b/examples/reverse/ReverseWW.hss new file mode 100644 --- /dev/null +++ b/examples/reverse/ReverseWW.hss @@ -0,0 +1,29 @@ +flatten-module +consider 'rev +{consider 'rev + load "../WWSplitTactic.hss" + {rhs-of 'work + any-call (unfold 'wrap) + any-call (unfold 'f) + any-call (unfold 'unwrap) + any-call (unfold '.) + simplify + alpha-lam 'ys + {0 + eta-expand 'acc + innermost case-float + one-td (unfold-rule "repH []") + one-td (unfold 'id) + one-td (unfold-rule "repH ++") + one-td (unfold-rule "rep-abs-fusion") + one-td (unfold 'repH) + any-call (unfold '.) + any-call (unfold-rule "(:) ++") + any-call (unfold-rule "[] ++") + } + } +} +any-call (unfold 'wrap) +any-call (unfold '.) +any-call (unfold 'absH) +simplify diff --git a/hermit.cabal b/hermit.cabal --- a/hermit.cabal +++ b/hermit.cabal @@ -1,5 +1,5 @@ Name: hermit -Version: 0.1.2.0 +Version: 0.1.4.0 Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel Description: HERMIT uses Haskell to express semi-formal models, @@ -17,7 +17,7 @@ . * log command prints linearly, even if command history is a tree. . - * The fold rewrite can only fold syntactically equivalent (up to + * The fold rewrite can only fold syntactically alpha-equivalent (up to parameters of the function you are folding) expressions. . * RULES have issues with forall types. @@ -38,12 +38,12 @@ . @ $ hermit Reverse.hs Reverse.hss resume - [starting HERMIT v0.1.2.0 on Reverse.hs] + [starting HERMIT v0.1.4.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main: -fplugin-opt=HERMIT:main:Main:resume [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ... - Loading package hermit-0.1.2.0 ... linking ... done. + Loading package hermit-0.1.4.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) Linking Reverse ... $ ./Reverse @@ -54,12 +54,12 @@ . @ $ hermit Reverse.hs - [starting HERMIT v0.1.2.0 on Reverse.hs] + [starting HERMIT v0.1.4.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:main:Main: [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ... - Loading package hermit-0.1.2.0 ... linking ... done. + Loading package hermit-0.1.4.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) module main:Main where \ \ rev ∷ ∀ a . [] a -> [] a @@ -87,40 +87,44 @@ Maintainer: Andy Gill Stability: pre-alpha build-type: Simple -Cabal-Version: >= 1.10 +Cabal-Version: >= 1.14 extra-source-files: + examples/WWSplitTactic.hss examples/concatVanishes/ConcatVanishes.hss examples/concatVanishes/Flatten.hs examples/concatVanishes/Flatten.hss examples/concatVanishes/HList.hs - examples/concatVanishes/Makefile examples/concatVanishes/QSort.hs examples/concatVanishes/QSort.hss examples/concatVanishes/Rev.hs examples/concatVanishes/Rev.hss - examples/contents.txt + examples/evaluation/Eval.hs + examples/evaluation/Eval.hss + examples/factorial/Fac.hs + examples/factorial/Fac.hss examples/fib-stream/Fib.hs examples/fib-stream/Fib.hss - examples/fib-stream/Makefile examples/fib-stream/Nat.hs examples/fib-stream/Stream.hs - examples/fib-stream/WWSplitTactic.hss examples/fib-tuple/Fib.hs examples/fib-tuple/Fib.hss - examples/fib-tuple/Makefile - examples/fib-tuple/WWSplitTactic.hss - examples/fib-tuple/blog.txt + examples/flatten/HList.hs + examples/flatten/Flatten.hs + examples/flatten/Flatten.hss examples/hanoi/Hanoi.hs examples/hanoi/Hanoi.hss - examples/hanoi/Makefile - examples/map/Map.hs - examples/map/Map.hss - examples/map/Makefile + examples/last/Last.hs + examples/last/Last.hss + examples/mean/Mean.hs + examples/mean/Mean.hss + examples/qsort/HList.hs + examples/qsort/QSort.hs + examples/qsort/QSort.hss examples/reverse/HList.hs - examples/reverse/Makefile examples/reverse/Reverse.hs examples/reverse/Reverse.hss + examples/reverse/ReverseWW.hss Library ghc-options: -Wall -fno-warn-orphans @@ -131,7 +135,7 @@ data-default >= 0.5.0, ghc == 7.6.*, haskeline >= 0.7.0.3, - kure >= 2.4.2, + kure >= 2.4.10, marked-pretty >= 0.1, mtl >= 2.1.2, stm >= 2.4, @@ -144,7 +148,7 @@ HERMIT Language.HERMIT.Context - Language.HERMIT.CoreExtra + Language.HERMIT.Core Language.HERMIT.Dictionary Language.HERMIT.Expr Language.HERMIT.External @@ -156,7 +160,9 @@ Language.HERMIT.Plugin + Language.HERMIT.Primitive.AlphaConversion Language.HERMIT.Primitive.Debug + Language.HERMIT.Primitive.FixPoint Language.HERMIT.Primitive.Fold Language.HERMIT.Primitive.GHC Language.HERMIT.Primitive.Inline @@ -166,9 +172,7 @@ Language.HERMIT.Primitive.Local.Case Language.HERMIT.Primitive.Navigation Language.HERMIT.Primitive.New - Language.HERMIT.Primitive.AlphaConversion Language.HERMIT.Primitive.Unfold - Language.HERMIT.Primitive.Utils Language.HERMIT.PrettyPrinter Language.HERMIT.PrettyPrinter.AST @@ -187,6 +191,7 @@ Executable hermit Build-Depends: base >= 4 && < 5, + directory >= 1.2.0.0, process default-language: Haskell2010 diff --git a/src/Language/HERMIT/Context.hs b/src/Language/HERMIT/Context.hs --- a/src/Language/HERMIT/Context.hs +++ b/src/Language/HERMIT/Context.hs @@ -1,31 +1,36 @@ {-# LANGUAGE InstanceSigs #-} module Language.HERMIT.Context - ( - -- * HERMIT Bindings - HermitBinding(..) - , hermitBindingDepth - -- * The HERMIT Context - , Context - , initContext + ( -- * The HERMIT Context + HermitC + , initHermitC + -- ** Adding to the Context , (@@) , addAltBindings , addBinding , addCaseBinding , addLambdaBinding + -- ** Reading from the Context , hermitBindings , hermitDepth , hermitPath , hermitModGuts , lookupHermitBinding - , listBindings + , boundVars , boundIn + , findBoundVars + -- ** Bindings + , HermitBinding(..) + , hermitBindingDepth ) where import Prelude hiding (lookup) import GhcPlugins hiding (empty) -import Data.Map hiding (map, foldr) +import Data.Map hiding (map, foldr, filter) +import qualified Language.Haskell.TH as TH +import Language.HERMIT.GHC + import Language.KURE ------------------------------------------------------------------------ @@ -35,8 +40,8 @@ = BIND Int Bool CoreExpr -- ^ Binding depth, whether it is recursive, and the bound value -- (which cannot be inlined without checking for scoping issues). | LAM Int -- ^ For a lambda binding you only know the depth. - | CASE Int CoreExpr (AltCon,[Id]) -- ^ For case wildcard binders. First expr points to scrutinee, - -- second to AltCon (which can be converted to Constructor or Literal). + | CASE Int CoreExpr (AltCon,[Id]) -- ^ For case wildcard binders. We store both the scrutinised expression, + -- and the case alternative 'AltCon' (which can be converted to Constructor or Literal) and identifiers. -- | Get the depth of a binding. hermitBindingDepth :: HermitBinding -> Int @@ -49,8 +54,8 @@ -- | The HERMIT context, containing all bindings in scope and the current location in the AST. -- The bindings here are lazy by choice, so that we can avoid the cost -- of building the context if we never use it. -data Context = Context - { hermitBindings :: Map Id HermitBinding -- ^ All (important) bindings in scope. +data HermitC = HermitC + { hermitBindings :: Map Var HermitBinding -- ^ All (important) bindings in scope. , hermitDepth :: Int -- ^ The depth of the bindings. , hermitPath :: AbsolutePath -- ^ The 'AbsolutePath' to the current node from the root. , hermitModGuts :: ModGuts -- ^ The 'ModGuts' of the current module. @@ -59,80 +64,75 @@ ------------------------------------------------------------------------ -- | The HERMIT context stores an 'AbsolutePath' to the current node in the tree. -instance PathContext Context where - contextPath :: Context -> AbsolutePath +instance PathContext HermitC where + contextPath :: HermitC -> AbsolutePath contextPath = hermitPath --- | Create the initial HERMIT 'Context' by providing a 'ModGuts'. -initContext :: ModGuts -> Context -initContext modGuts = Context empty 0 rootAbsPath modGuts +-- | Create the initial HERMIT 'HermitC' by providing a 'ModGuts'. +initHermitC :: ModGuts -> HermitC +initHermitC modGuts = HermitC empty 0 rootAbsPath modGuts -- | Update the context by extending the stored 'AbsolutePath' to a child. -(@@) :: Context -> Int -> Context -(@@) env n = env { hermitPath = extendAbsPath n (hermitPath env) } +(@@) :: HermitC -> Int -> HermitC +(@@) c v = c { hermitPath = extendAbsPath v (hermitPath c) } --- | Add all bindings in a binding group to the 'Context'. -addBinding :: CoreBind -> Context -> Context -addBinding (NonRec n e) env - = env { hermitBindings = insert n (BIND next_depth False e) (hermitBindings env) - , hermitDepth = next_depth - } - where - next_depth = succ (hermitDepth env) -addBinding (Rec bds) env - = env { hermitBindings = bds_env `union` hermitBindings env - , hermitDepth = next_depth - } - where - next_depth = succ (hermitDepth env) - -- notice how all recursive binding in a binding group are at the same depth. - bds_env = fromList - [ (b,BIND next_depth True e) - | (b,e) <- bds - ] +------------------------------------------------------------------------ +-- | Add all bindings in a binding group to a context. +addBinding :: CoreBind -> HermitC -> HermitC +addBinding corebind c = let nextDepth = succ (hermitDepth c) + hbds = hermitBindings c + newBds = case corebind of + NonRec v e -> insert v (BIND nextDepth False e) hbds + Rec bds -> hbds `union` fromList [ (b, BIND nextDepth True e) | (b,e) <- bds ] + -- Notice how all recursive binding in a binding group are at the same depth. + in c { hermitBindings = newBds + , hermitDepth = nextDepth + } + -- | Add the bindings for a specific case alternative. -addCaseBinding :: (Id,CoreExpr,CoreAlt) -> Context -> Context -addCaseBinding (n,e,(ac,is,_)) env - = env { hermitBindings = insert n (CASE next_depth e (ac,is)) (hermitBindings env) - , hermitDepth = next_depth - } - where - next_depth = succ (hermitDepth env) +addCaseBinding :: (Id,CoreExpr,CoreAlt) -> HermitC -> HermitC +addCaseBinding (v,e,(con,vs,_)) c = let nextDepth = succ (hermitDepth c) + in c { hermitBindings = insert v (CASE nextDepth e (con,vs)) (hermitBindings c) + , hermitDepth = nextDepth + } --- | Add a binding that you know nothing about, except that it may shadow something. --- If so, do not worry about it here, just remember the binding and the depth. --- When we want to inline a value from the environment, --- we then check to see what is free in the inlinee, and see --- if any of the frees will stop the validity of the inlining. -addLambdaBinding :: Id -> Context -> Context -addLambdaBinding n env - = env { hermitBindings = insert n (LAM next_depth) (hermitBindings env) - , hermitDepth = next_depth - } - where - next_depth = succ (hermitDepth env) +-- | Add a lambda bound variable to a context. +-- All that is known is the variable, which may shadow something. +-- If so, we don't worry about that here, it is instead checked during inlining. +addLambdaBinding :: Var -> HermitC -> HermitC +addLambdaBinding v c = let nextDepth = succ (hermitDepth c) + in c { hermitBindings = insert v (LAM nextDepth) (hermitBindings c) + , hermitDepth = nextDepth + } --- | Add the Ids bound by a DataCon in a case. Like lambda bindings, +-- | Add the identifiers bound by a 'DataCon' in a case. Like lambda bindings, -- in that we know nothing about them, but all bound at the same depth, --- so we cannot just fold addLambdaBinding over the list. -addAltBindings :: [Id] -> Context -> Context -addAltBindings ns env - = env { hermitBindings = foldr (\n bds -> insert n (LAM next_depth) bds) (hermitBindings env) ns - , hermitDepth = next_depth - } - where next_depth = succ (hermitDepth env) +-- so we cannot just fold 'addLambdaBinding' over the list. +addAltBindings :: [Id] -> HermitC -> HermitC +addAltBindings vs c = let nextDepth = succ (hermitDepth c) + in c { hermitBindings = foldr (\ v bds -> insert v (LAM nextDepth) bds) (hermitBindings c) vs + , hermitDepth = nextDepth + } --- | Lookup the binding for an identifier in a 'Context'. -lookupHermitBinding :: Id -> Context -> Maybe HermitBinding +------------------------------------------------------------------------ + +-- | Lookup the binding for a variable in a context. +lookupHermitBinding :: Var -> HermitC -> Maybe HermitBinding lookupHermitBinding n env = lookup n (hermitBindings env) --- | List all the identifiers bound in the 'Context'. -listBindings :: Context -> [Id] -listBindings = keys . hermitBindings +-- | List all the variables bound in a context. +boundVars :: HermitC -> [Var] +boundVars = keys . hermitBindings --- | Determine if an identifier is bound in the 'Context'. -boundIn :: Id -> Context -> Bool -boundIn i c = i `elem` listBindings c +-- | Determine if a variable is bound in a context. +boundIn :: Var -> HermitC -> Bool +boundIn i c = i `elem` boundVars c + +------------------------------------------------------------------------ + +-- | List all variables bound in the context that match the given name. +findBoundVars :: TH.Name -> HermitC -> [Var] +findBoundVars nm = filter (cmpTHName2Var nm) . boundVars ------------------------------------------------------------------------ diff --git a/src/Language/HERMIT/Core.hs b/src/Language/HERMIT/Core.hs new file mode 100644 --- /dev/null +++ b/src/Language/HERMIT/Core.hs @@ -0,0 +1,115 @@ +module Language.HERMIT.Core + ( + -- * Generic Data Type + -- $typenote + Core(..) + , CoreProg(..) + , CoreDef(..) + , CoreTickish + -- * Conversions to/from 'Core' + , defsToRecBind + , defToIdExpr + , progToBinds + , bindsToProg + , bindToIdExprs + -- * Utilities + , isType + , typeExprToType + , exprTypeOrKind + , appCount +) where + +import Data.Maybe(isJust) + +import GhcPlugins + +--------------------------------------------------------------------- + +-- $typenote +-- NOTE: 'Type' is not included in the generic datatype. +-- However, we could have included it and provided the facility for descending into types. +-- We have not done so because +-- (a) we do not need that functionality, and +-- (b) the types are complicated and we're not sure that we understand them. + +-- | Core is the sum type of all nodes in the AST that we wish to be able to traverse. +-- All 'Node' instances in HERMIT define their 'Generic' type to be 'Core'. +data Core = ModGutsCore ModGuts -- ^ The module. + | ProgCore CoreProg -- ^ A program (a telescope of top-level binding groups). + | BindCore CoreBind -- ^ A binding group. + | DefCore CoreDef -- ^ A recursive definition. + | ExprCore CoreExpr -- ^ An expression. + | AltCore CoreAlt -- ^ A case alternative. + +--------------------------------------------------------------------- + +-- | A program is a telescope of nested binding groups. +-- That is, each binding scopes over the remainder of the program. +-- In GHC Core, programs are encoded as ['CoreBind']. +-- This data type is isomorphic. +data CoreProg = ProgNil -- ^ An empty program. + | ProgCons CoreBind CoreProg -- ^ A binding group and the program it scopes over. + +infixr 5 `ProgCons` + +-- | Get the list of bindings in a program. +progToBinds :: CoreProg -> [CoreBind] +progToBinds ProgNil = [] +progToBinds (ProgCons bd p) = bd : progToBinds p + +-- | Build a program from a list of bindings. +-- Note that bindings earlier in the list are considered scope over bindings later in the list. +bindsToProg :: [CoreBind] -> CoreProg +bindsToProg = foldr ProgCons ProgNil + +-- | Extract the list of identifier/expression pairs from a binding group. +bindToIdExprs :: CoreBind -> [(Id,CoreExpr)] +bindToIdExprs (NonRec v e) = [(v,e)] +bindToIdExprs (Rec bds) = bds + +-- | A (potentially recursive) definition is an identifier and an expression. +-- In GHC Core, recursive definitions are encoded as ('Id', 'CoreExpr') pairs. +-- This data type is isomorphic. +data CoreDef = Def Id CoreExpr + +-- | Convert a definition to an identifier/expression pair. +defToIdExpr :: CoreDef -> (Id,CoreExpr) +defToIdExpr (Def v e) = (v,e) + +-- | Convert a list of recursive definitions into an (isomorphic) recursive binding group. +defsToRecBind :: [CoreDef] -> CoreBind +defsToRecBind = Rec . map defToIdExpr + +----------------------------------------------------------------------- + +-- | Unlike everything else, there is no synonym for 'Tickish' 'Id' provided by GHC, so we define one. +type CoreTickish = Tickish Id + +----------------------------------------------------------------------- + +-- TODO: I don't know what to do about Coercions here, because I don't understand them. + +-- | Succeeds if the expression is either a 'Type' or type 'Var'. +isType :: CoreExpr -> Bool +isType = isJust . typeExprToType + +-- | Convert a 'CoreExpr' expression that \is\ a 'Type' into a 'Type'. +typeExprToType :: CoreExpr -> Maybe Type +typeExprToType (Type t) = Just t +typeExprToType (Var v) | isTKVar v = Just (mkTyVarTy v) +typeExprToType _ = Nothing + +-- | GHC's 'exprType' function throws an error if applied to a 'Type' (but, inconsistently, return a 'Kind' if applied to a type variable). +-- This function returns the 'Kind' of a 'Type', but otherwise behaves as 'exprType'. +exprTypeOrKind :: CoreExpr -> Type +exprTypeOrKind (Type t) = typeKind t +exprTypeOrKind e = exprType e + +----------------------------------------------------------------------- + +-- | Count the number of nested applications. +appCount :: CoreExpr -> Int +appCount (App e1 _) = appCount e1 + 1 +appCount _ = 0 + +----------------------------------------------------------------------- diff --git a/src/Language/HERMIT/CoreExtra.hs b/src/Language/HERMIT/CoreExtra.hs deleted file mode 100644 --- a/src/Language/HERMIT/CoreExtra.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Language.HERMIT.CoreExtra - ( - -- * Generic Data Type - -- $typenote - Core(..) - , CoreDef(..) - -- * GHC Core Extras - , CoreTickish - , defToRecBind -) where - -import GhcPlugins - ---------------------------------------------------------------------- - --- $typenote --- NOTE: 'Type' is not included in the generic datatype. --- However, we could have included it and provided the facility for descending into types. --- We have not done so because --- (a) we do not need that functionality, and --- (b) the types are complicated and we're not sure that we understand them. - --- | Core is the sum type of all nodes in the AST that we wish to be able to traverse. --- All 'Node' instances in HERMIT define their 'Generic' type to be 'Core'. -data Core = ModGutsCore ModGuts -- ^ The module. - | ProgramCore CoreProgram -- ^ A program (list of top-level bindings). - | BindCore CoreBind -- ^ A binding group. - | DefCore CoreDef -- ^ A recursive definition. - | ExprCore CoreExpr -- ^ An expression. - | AltCore CoreAlt -- ^ A case alternative. - ---------------------------------------------------------------------- - --- | A (potentially recursive) definition is an identifier and an expression. --- In GHC Core, recursive definitions are encoded as ('Id', 'CoreExpr') pairs. --- This data type is isomorphic. -data CoreDef = Def Id CoreExpr - ------------------------------------------------------------------------ - --- | Unlike everything else, there is no synonym for 'Tickish' 'Id' provided by GHC, so we provide one. -type CoreTickish = Tickish Id - --- | Convert a list of recursive definitions into an (isomorphic) recursive binding group. -defToRecBind :: [CoreDef] -> CoreBind -defToRecBind = Rec . map (\ (Def v e) -> (v,e)) - ------------------------------------------------------------------------ diff --git a/src/Language/HERMIT/Dictionary.hs b/src/Language/HERMIT/Dictionary.hs --- a/src/Language/HERMIT/Dictionary.hs +++ b/src/Language/HERMIT/Dictionary.hs @@ -3,20 +3,21 @@ module Language.HERMIT.Dictionary ( -- * The HERMIT Dictionary -- | This is the main namespace. Things tend to be untyped, because the API is accessed via (untyped) names. - all_externals + Dictionary + , all_externals , dictionary , pp_dictionary ) where -import Data.Default (def) +-- import Data.Default (def) import Data.Dynamic import Data.List import Data.Map (Map, fromList, toList) +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External ---import qualified Language.HERMIT.Primitive.Command as Command import qualified Language.HERMIT.Primitive.Kure as Kure import qualified Language.HERMIT.Primitive.Navigation as Navigation import qualified Language.HERMIT.Primitive.Inline as Inline @@ -24,6 +25,7 @@ import qualified Language.HERMIT.Primitive.New as New import qualified Language.HERMIT.Primitive.Debug as Debug import qualified Language.HERMIT.Primitive.GHC as GHC +import qualified Language.HERMIT.Primitive.FixPoint as FixPoint import qualified Language.HERMIT.Primitive.Fold as Fold import qualified Language.HERMIT.Primitive.Unfold as Unfold import qualified Language.HERMIT.Primitive.AlphaConversion as Alpha @@ -36,6 +38,10 @@ -------------------------------------------------------------------------- +-- | A 'Dictionary' is a collection of 'Dynamic's. +-- Looking up a 'Dynamic' (via a 'String' key) returns a list, as there can be multiple 'Dynamic's with the same name. +type Dictionary = Map String [Dynamic] + prim_externals :: [External] prim_externals = Kure.externals @@ -44,6 +50,7 @@ ++ Local.externals ++ Debug.externals ++ New.externals + ++ FixPoint.externals ++ Fold.externals ++ Unfold.externals ++ Alpha.externals @@ -53,8 +60,8 @@ all_externals :: [External] -> [External] all_externals my_externals = prim_externals ++ my_externals ++ GHC.externals --- | Create the dictionary. -dictionary :: [External] -> Map String [Dynamic] +-- | Create a dictionary from a list of 'External's. +dictionary :: [External] -> Dictionary dictionary externs = toDictionary externs' where msg = layoutTxt 60 (map (show . fst) dictionaryOfTags) @@ -88,6 +95,7 @@ , ("ghc", GHCPP.corePrettyH) ] +{- -- (This isn't used anywhere currently.) -- | Each pretty printer can suggest some options pp_opt_dictionary :: Map String PrettyOptions @@ -96,7 +104,7 @@ , ("ast", def) , ("ghc", def) ] - +-} -------------------------------------------------------------------------- @@ -150,3 +158,5 @@ , tagMatch p e -- necessary so we don't list things that don't type correctly , Just (_ :: RewriteH Core) <- [fmap unbox $ fromDynamic $ externFun e] ]) + +------------------------------------ diff --git a/src/Language/HERMIT/Expr.hs b/src/Language/HERMIT/Expr.hs --- a/src/Language/HERMIT/Expr.hs +++ b/src/Language/HERMIT/Expr.hs @@ -135,7 +135,7 @@ parseExprH0 inp = [ (Box (CmdName str),inp1) | (str,inp1) <- parseToken inp - , isAlphaNum (head str) || head str == ':' -- commands can start with : + , isAlphaNum (head str) || head str == ':' -- commands can start with : -- This can probably be removed now, as we no longer start commands with : , all isId (tail str) ] ++ [ (InfixableExpr (CmdName str),inp1) @@ -210,7 +210,7 @@ isId c = isAlphaNum c || c `elem` "_-'" isInfixId :: Char -> Bool -isInfixId c = c `elem` "+._-:<>" +isInfixId c = c `elem` "+*/._-:<>" --------------------------------------------- diff --git a/src/Language/HERMIT/External.hs b/src/Language/HERMIT/External.hs --- a/src/Language/HERMIT/External.hs +++ b/src/Language/HERMIT/External.hs @@ -42,6 +42,7 @@ import qualified Language.Haskell.TH as TH +import Language.HERMIT.Core import Language.HERMIT.Kure ----------------------------------------------------------------- @@ -58,7 +59,6 @@ -- (or the help function will not find it). -- These should be /user facing/, because they give the user -- a way of sub-dividing our confusing array of commands. - data CmdTag = Shell -- ^ Shell command. | Eval -- ^ The arrow of evaluation (reduces a term). | KURE -- ^ 'Language.KURE' command. diff --git a/src/Language/HERMIT/GHC.hs b/src/Language/HERMIT/GHC.hs --- a/src/Language/HERMIT/GHC.hs +++ b/src/Language/HERMIT/GHC.hs @@ -1,14 +1,16 @@ module Language.HERMIT.GHC - ( + ( -- * GHC Imports -- | Things that have been copied from GHC, or imported directly, for various reasons. ppIdInfo , var2String , thRdrNameGuesses , name2THName - , id2THName + , var2THName , cmpTHName2Name - , cmpTHName2Id - , unqualifiedIdName + , cmpString2Name + , cmpTHName2Var + , cmpString2Var + , unqualifiedVarName , findNameFromTH , alphaTyVars , Type(..) @@ -31,7 +33,6 @@ -------------------------------------------------------------------------- --- idName :: Id -> Name -- varName :: Var -> Name -- nameOccName :: Name -> OccName -- occNameString :: OccName -> String @@ -44,27 +45,35 @@ -- | Convert a variable to a neat string for printing. var2String :: Var -> String -var2String = occNameString . nameOccName . varName +var2String = occNameString . nameOccName . varName -- TODO: would getOccString be okay here? -- | Converts a GHC 'Name' to a Template Haskell 'TH.Name', going via a 'String'. name2THName :: Name -> TH.Name name2THName = TH.mkName . getOccString --- | Converts an 'Id' to a Template Haskell 'TH.Name', going via a 'String'. -id2THName :: Id -> TH.Name -id2THName = name2THName . idName +-- | Converts an 'Var' to a Template Haskell 'TH.Name', going via a 'String'. +var2THName :: Var -> TH.Name +var2THName = name2THName . varName --- | Get the unqualified name from an Id/Var. -unqualifiedIdName :: Id -> String -unqualifiedIdName = TH.nameBase . id2THName +-- | Get the unqualified name from an Var. +unqualifiedVarName :: Var -> String +unqualifiedVarName = TH.nameBase . var2THName -- | Hacks until we can find the correct way of doing these. cmpTHName2Name :: TH.Name -> Name -> Bool -cmpTHName2Name th_nm ghc_nm = TH.nameBase th_nm == getOccString ghc_nm -- occNameString (nameOccName ghc_nm) +cmpTHName2Name th_nm = cmpString2Name (TH.nameBase th_nm) -- | Hacks until we can find the correct way of doing these. -cmpTHName2Id :: TH.Name -> Id -> Bool -cmpTHName2Id nm = cmpTHName2Name nm . idName +cmpString2Name :: String -> Name -> Bool +cmpString2Name str nm = str == getOccString nm -- occNameString (nameOccName ghc_nm) + +-- | Hacks until we can find the correct way of doing these. +cmpTHName2Var :: TH.Name -> Var -> Bool +cmpTHName2Var nm = cmpTHName2Name nm . varName + +-- | Hacks until we can find the correct way of doing these. +cmpString2Var :: String -> Var -> Bool +cmpString2Var str = cmpString2Name str . varName -- | This is hopeless O(n), because the we could not generate the 'OccName's that match, -- for use of the GHC 'OccEnv'. diff --git a/src/Language/HERMIT/Interp.hs b/src/Language/HERMIT/Interp.hs --- a/src/Language/HERMIT/Interp.hs +++ b/src/Language/HERMIT/Interp.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, GADTs #-} +{-# LANGUAGE KindSignatures, GADTs, InstanceSigs #-} module Language.HERMIT.Interp ( -- * The HERMIT Interpreter @@ -40,7 +40,8 @@ interp = Interp instance Functor Interp where - fmap f (Interp g) = Interp (f . g) + fmap :: (a -> b) -> Interp a -> Interp b + fmap f (Interp g) = Interp (f . g) interpExpr :: M.Map String [Dynamic] -> ExprH -> Either String [Dynamic] @@ -49,7 +50,11 @@ interpExpr' :: Bool -> M.Map String [Dynamic] -> ExprH -> Either String [Dynamic] interpExpr' _ _ (SrcName str) = return [ toDyn $ NameBox $ TH.mkName str ] interpExpr' rhs env (CmdName str) - | all isDigit str = return [ toDyn $ IntBox $ read str ] + -- An Int is either a Path, or will be interpreted specially later. + | all isDigit str = let i = read str in + return [ toDyn $ IntBox i + , toDyn $ TranslateCorePathBox (return [i]) + ] | Just dyn <- M.lookup str env = return $ if rhs then toDyn (StringBox str) : dyn else dyn @@ -64,4 +69,3 @@ where dynApply' :: [Dynamic] -> [Dynamic] -> [Dynamic] dynApply' fs xs = [ r | f <- fs, x <- xs, Just r <- return (dynApply f x)] - diff --git a/src/Language/HERMIT/Kernel.hs b/src/Language/HERMIT/Kernel.hs --- a/src/Language/HERMIT/Kernel.hs +++ b/src/Language/HERMIT/Kernel.hs @@ -25,23 +25,23 @@ import Data.Map import Control.Concurrent --- | A 'Kernel' is a repository for Core syntax trees. +-- | A 'Kernel' is a repository for complete Core syntax trees ('ModGuts'). -- For now, operations on a 'Kernel' are sequential, but later -- it will be possible to have two 'applyK's running in parallel. data Kernel = Kernel - { resumeK :: AST -> IO () -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'. - , abortK :: IO () -- ^ Halt the 'Kernel' and abort GHC without compiling. - , applyK :: AST -> RewriteH Core -> HermitMEnv -> IO (KureMonad AST) -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'. - , queryK :: forall a . AST -> TranslateH Core a -> HermitMEnv -> IO (KureMonad a) -- ^ Apply a 'TranslateH' to the 'AST' and return the resulting value. - , deleteK :: AST -> IO () -- ^ Delete the internal record of the specified 'AST'. - , listK :: IO [AST] -- ^ List all the 'AST's tracked by the 'Kernel'. + { resumeK :: AST -> IO () -- ^ Halt the 'Kernel' and return control to GHC, which compiles the specified 'AST'. + , abortK :: IO () -- ^ Halt the 'Kernel' and abort GHC without compiling. + , applyK :: AST -> RewriteH ModGuts -> HermitMEnv -> IO (KureM AST) -- ^ Apply a 'Rewrite' to the specified 'AST' and return a handle to the resulting 'AST'. + , queryK :: forall a . AST -> TranslateH ModGuts a -> HermitMEnv -> IO (KureM a) -- ^ Apply a 'TranslateH' to the 'AST' and return the resulting value. + , deleteK :: AST -> IO () -- ^ Delete the internal record of the specified 'AST'. + , listK :: IO [AST] -- ^ List all the 'AST's tracked by the 'Kernel'. } -- | A /handle/ for a specific version of the 'ModGuts'. newtype AST = AST Int -- ^ Currently 'AST's are identified by an 'Int' label. deriving (Eq, Ord, Show) -data Msg s r = forall a . Req (s -> CoreM (KureMonad (a,s))) (MVar (KureMonad a)) +data Msg s r = forall a . Req (s -> CoreM (KureM (a,s))) (MVar (KureM a)) | Done (s -> CoreM r) type KernelState = Map AST (DefStash, ModGuts) @@ -54,25 +54,25 @@ msgMV :: MVar (Msg KernelState ModGuts) <- liftIO newEmptyMVar - syntax_names :: MVar AST <- liftIO newEmptyMVar + nextASTname :: MVar AST <- liftIO newEmptyMVar - _ <- liftIO $ forkIO $ let loop n = do putMVar syntax_names (AST n) + _ <- liftIO $ forkIO $ let loop n = do putMVar nextASTname (AST n) loop (succ n) in loop 0 let sendDone :: (KernelState -> CoreM ModGuts) -> IO () sendDone = putMVar msgMV . Done - let sendReq :: (KernelState -> CoreM (KureMonad (a, KernelState))) -> IO (KureMonad a) + let sendReq :: (KernelState -> CoreM (KureM (a, KernelState))) -> IO (KureM a) sendReq fn = do rep <- newEmptyMVar putMVar msgMV (Req fn rep) takeMVar rep - let sendReqRead :: (KernelState -> CoreM (KureMonad a)) -> IO (KureMonad a) + let sendReqRead :: (KernelState -> CoreM (KureM a)) -> IO (KureM a) sendReqRead fn = sendReq (\ st -> (fmap.fmap) (,st) $ fn st) let sendReqWrite :: (KernelState -> CoreM KernelState) -> IO () - sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= runKureMonad return fail + sendReqWrite fn = sendReq (fmap ( return . ((),) ) . fn) >>= runKureM return fail let kernel :: Kernel kernel = Kernel @@ -80,38 +80,38 @@ , abortK = sendDone $ \ _ -> throwGhcException (ProgramError "Exiting HERMIT and aborting GHC compilation.") - , applyK = \ name r hm_env -> sendReq $ \ st -> findWithErrMsg name st fail $ \ (defs, core) -> runHM hm_env + , applyK = \ name r hm_env -> sendReq $ \ st -> findWithErrMsg name st fail $ \ (defs, guts) -> runHM hm_env defs - (\ defs' core' -> do syn' <- liftIO $ takeMVar syntax_names - return $ return (syn', insert syn' (defs',core') st)) + (\ defs' guts' -> do ast <- liftIO $ takeMVar nextASTname + return $ return (ast, insert ast (defs',guts') st)) (return . fail) - (apply (extractR r) (initContext core) core) + (apply r (initHermitC guts) guts) - , queryK = \ name q hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, core) -> runHM hm_env - defs - (\ _ -> return.return) - (return . fail) - (apply (extractT q) (initContext core) core) + , queryK = \ name t hm_env -> sendReqRead $ \ st -> findWithErrMsg name st fail $ \ (defs, core) -> runHM hm_env + defs + (\ _ -> return.return) + (return . fail) + (apply t (initHermitC core) core) , deleteK = \ name -> sendReqWrite (return . delete name) - , listK = sendReqRead (return . return . keys) >>= runKureMonad return fail + , listK = sendReqRead (return . return . keys) >>= runKureM return fail } - -- We always start with syntax blob 0 - syn <- liftIO $ takeMVar syntax_names + -- We always start with AST 0 + ast0 <- liftIO $ takeMVar nextASTname let loop :: KernelState -> CoreM ModGuts loop st = do m <- liftIO $ takeMVar msgMV case m of - Req fn rep -> fn st >>= runKureMonad (\ (a,st') -> liftIO (putMVar rep $ return a) >> loop st') - (\ msg -> liftIO (putMVar rep $ fail msg) >> loop st) + Req fn rep -> fn st >>= runKureM (\ (a,st') -> liftIO (putMVar rep $ return a) >> loop st') + (\ msg -> liftIO (putMVar rep $ fail msg) >> loop st) Done fn -> fn st - _pid <- liftIO $ forkIO $ callback kernel syn + _pid <- liftIO $ forkIO $ callback kernel ast0 - loop (singleton syn (empty, modGuts)) + loop (singleton ast0 (empty, modGuts)) -- (Kill the pid'd thread? do we need to?) diff --git a/src/Language/HERMIT/Kernel/Scoped.hs b/src/Language/HERMIT/Kernel/Scoped.hs --- a/src/Language/HERMIT/Kernel/Scoped.hs +++ b/src/Language/HERMIT/Kernel/Scoped.hs @@ -10,6 +10,7 @@ , scopedKernel ) where +import Control.Arrow import Control.Concurrent.STM import Control.Exception.Base (bracketOnError) @@ -17,9 +18,10 @@ import GhcPlugins hiding (Direction,L) +import Language.HERMIT.Core import Language.HERMIT.Kure -import Language.HERMIT.Kernel import Language.HERMIT.Monad +import Language.HERMIT.Kernel ---------------------------------------------------------------------------- @@ -65,8 +67,8 @@ extendLocalPath :: Path -> LocalPath -> LocalPath extendLocalPath p (LocalPath lp) = LocalPath (reverse p ++ lp) -pathStackToLens :: [LocalPath] -> LocalPath -> LensH Core Core -pathStackToLens ps p = pathL $ concat $ localPaths2Paths (p:ps) +pathStackToLens :: [LocalPath] -> LocalPath -> LensH ModGuts Core +pathStackToLens ps p = injectL >>> pathL (concat $ localPaths2Paths (p:ps)) ---------------------------------------------------------------------------- @@ -74,12 +76,12 @@ data ScopedKernel = ScopedKernel { resumeS :: SAST -> IO () , abortS :: IO () - , applyS :: SAST -> RewriteH Core -> HermitMEnv -> IO (KureMonad SAST) - , queryS :: forall a . SAST -> TranslateH Core a -> HermitMEnv -> IO (KureMonad a) + , applyS :: SAST -> RewriteH Core -> HermitMEnv -> IO (KureM SAST) + , queryS :: forall a . SAST -> TranslateH Core a -> HermitMEnv -> IO (KureM a) , deleteS :: SAST -> IO () , listS :: IO [SAST] , pathS :: SAST -> IO [Path] - , modPathS :: SAST -> (LocalPath -> LocalPath) -> HermitMEnv -> IO (KureMonad SAST) + , modPathS :: SAST -> (LocalPath -> LocalPath) -> HermitMEnv -> IO (KureM SAST) , beginScopeS :: SAST -> IO SAST , endScopeS :: SAST -> IO SAST } @@ -103,7 +105,7 @@ store <- newTMVarIO $ I.fromList [(0,(initAST, [], emptyLocalPath))] key <- newTMVarIO (1::Int) - let failCleanup :: SASTStore -> String -> IO (KureMonad a) + let failCleanup :: SASTStore -> String -> IO (KureM a) failCleanup m msg = atomically $ do putTMVar store m return $ fail msg @@ -121,9 +123,9 @@ , applyS = \ (SAST sAst) rr env -> safeTakeTMVar store $ \ m -> do (ast, base, rel) <- get sAst m applyK kernel ast (focusR (pathStackToLens base rel) rr) env - >>= runKureMonad (\ ast' -> atomically $ do k <- newKey - putTMVar store $ I.insert k (ast', base, rel) m - return $ return $ SAST k) + >>= runKureM (\ ast' -> atomically $ do k <- newKey + putTMVar store $ I.insert k (ast', base, rel) m + return $ return $ SAST k) (failCleanup m) , queryS = \ (SAST sAst) t env -> do m <- atomically $ readTMVar store @@ -142,13 +144,13 @@ (ast, base, rel) <- get sAst m let rel' = f rel queryK kernel ast (testLensT (pathStackToLens base rel')) env - >>= runKureMonad (\ b -> if rel == rel' - then failCleanup m "Path is unchanged, nothing to do." - else if b - then atomically $ do k <- newKey - putTMVar store $ I.insert k (ast, base, rel') m - return (return $ SAST k) - else failCleanup m "Invalid path created.") + >>= runKureM (\ b -> if rel == rel' + then failCleanup m "Path is unchanged, nothing to do." + else if b + then atomically $ do k <- newKey + putTMVar store $ I.insert k (ast, base, rel') m + return (return $ SAST k) + else failCleanup m "Invalid path created.") (failCleanup m) , beginScopeS = \ (SAST sAst) -> atomically $ do m <- takeTMVar store diff --git a/src/Language/HERMIT/Kure.hs b/src/Language/HERMIT/Kure.hs --- a/src/Language/HERMIT/Kure.hs +++ b/src/Language/HERMIT/Kure.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, TupleSections, LambdaCase, InstanceSigs #-} +-- Note: InstanceSigs don't expand type families (annoyingly), as of GHC 7.6.1. Check if this has been fixed in the next version. + module Language.HERMIT.Kure ( -- * KURE Modules @@ -7,22 +9,19 @@ -- | All the required functionality of KURE is exported here, so other modules do not need to import KURE directly. module Language.KURE , module Language.KURE.Injection - , KureMonad, runKureMonad, fromKureMonad + , KureM, runKureM, fromKureM -- * Synonyms -- | In HERMIT, 'Translate', 'Rewrite' and 'Lens' always operate on the same context and monad. , TranslateH , RewriteH , LensH , idR - -- * Generic Data Type - , Core(..) - , CoreDef(..) -- * Congruence combinators -- ** Modguts , modGutsT, modGutsR -- ** Program - , nilT - , consBindT, consBindAllR, consBindAnyR, consBindOneR + , progNilT + , progConsT, progConsAllR, progConsAnyR, progConsOneR -- ** Binding Groups , nonRecT, nonRecR , recT, recAllR, recAnyR, recOneR @@ -53,14 +52,14 @@ -- * Promotion Combinators -- ** Rewrite Promotions , promoteModGutsR - , promoteProgramR + , promoteProgR , promoteBindR , promoteDefR , promoteExprR , promoteAltR -- ** Translate Promotions , promoteModGutsT - , promoteProgramT + , promoteProgT , promoteBindT , promoteDefT , promoteExprT @@ -74,7 +73,7 @@ import Language.KURE.Injection import Language.KURE.Utilities -import Language.HERMIT.CoreExtra +import Language.HERMIT.Core import Language.HERMIT.Context import Language.HERMIT.Monad @@ -85,9 +84,9 @@ --------------------------------------------------------------------- -type TranslateH a b = Translate Context HermitM a b -type RewriteH a = Rewrite Context HermitM a -type LensH a b = Lens Context HermitM a b +type TranslateH a b = Translate HermitC HermitM a b +type RewriteH a = Rewrite HermitC HermitM a +type LensH a b = Lens HermitC HermitM a b -- | A synonym for the identity rewrite. Convienient to avoid importing Control.Category. idR :: RewriteH a @@ -98,8 +97,9 @@ instance Node Core where type Generic Core = Core + numChildren :: Core -> Int numChildren (ModGutsCore x) = numChildren x - numChildren (ProgramCore x) = numChildren x + numChildren (ProgCore x) = numChildren x numChildren (BindCore x) = numChildren x numChildren (DefCore x) = numChildren x numChildren (ExprCore x) = numChildren x @@ -108,50 +108,57 @@ -- Defining Walker instances for the Generic type 'Core' is almost entirely automated by KURE. -- Unfortunately, you still need to pattern match on the 'Core' data type. -instance Walker Context HermitM Core where - childL n = lens $ translate $ \ c core -> case core of +instance Walker HermitC HermitM Core where + + childL :: Int -> LensH Core (Generic Core) + childL n = lens $ translate $ \ c -> \case ModGutsCore x -> childLgeneric n c x - ProgramCore x -> childLgeneric n c x + ProgCore x -> childLgeneric n c x BindCore x -> childLgeneric n c x DefCore x -> childLgeneric n c x ExprCore x -> childLgeneric n c x AltCore x -> childLgeneric n c x - allT t = translate $ \ c core -> case core of + allT :: Monoid b => TranslateH (Generic Core) b -> TranslateH Core b + allT t = translate $ \ c -> \case ModGutsCore x -> allTgeneric t c x - ProgramCore x -> allTgeneric t c x + ProgCore x -> allTgeneric t c x BindCore x -> allTgeneric t c x DefCore x -> allTgeneric t c x ExprCore x -> allTgeneric t c x AltCore x -> allTgeneric t c x - oneT t = translate $ \ c core -> case core of + oneT :: TranslateH (Generic Core) b -> TranslateH Core b + oneT t = translate $ \ c -> \case ModGutsCore x -> oneTgeneric t c x - ProgramCore x -> oneTgeneric t c x + ProgCore x -> oneTgeneric t c x BindCore x -> oneTgeneric t c x DefCore x -> oneTgeneric t c x ExprCore x -> oneTgeneric t c x AltCore x -> oneTgeneric t c x - allR r = rewrite $ \ c core -> case core of + allR :: RewriteH (Generic Core) -> RewriteH Core + allR r = rewrite $ \ c -> \case ModGutsCore x -> allRgeneric r c x - ProgramCore x -> allRgeneric r c x + ProgCore x -> allRgeneric r c x BindCore x -> allRgeneric r c x DefCore x -> allRgeneric r c x ExprCore x -> allRgeneric r c x AltCore x -> allRgeneric r c x - anyR r = rewrite $ \ c core -> case core of + anyR :: RewriteH (Generic Core) -> RewriteH Core + anyR r = rewrite $ \ c -> \case ModGutsCore x -> anyRgeneric r c x - ProgramCore x -> anyRgeneric r c x + ProgCore x -> anyRgeneric r c x BindCore x -> anyRgeneric r c x DefCore x -> anyRgeneric r c x ExprCore x -> anyRgeneric r c x AltCore x -> anyRgeneric r c x - oneR r = rewrite $ \ c core -> case core of + oneR :: RewriteH (Generic Core) -> RewriteH Core + oneR r = rewrite $ \ c -> \case ModGutsCore x -> oneRgeneric r c x - ProgramCore x -> oneRgeneric r c x + ProgCore x -> oneRgeneric r c x BindCore x -> oneRgeneric r c x DefCore x -> oneRgeneric r c x ExprCore x -> oneRgeneric r c x @@ -160,87 +167,109 @@ --------------------------------------------------------------------- instance Injection ModGuts Core where - inject = ModGutsCore + + inject :: ModGuts -> Core + inject = ModGutsCore + + retract :: Core -> Maybe ModGuts retract (ModGutsCore guts) = Just guts retract _ = Nothing instance Node ModGuts where type Generic ModGuts = Core + numChildren :: ModGuts -> Int numChildren _ = 1 -instance Walker Context HermitM ModGuts where - childL 0 = lens $ modGutsT exposeT (childL1of2 $ \ modguts bds -> modguts {mg_binds = bds}) +instance Walker HermitC HermitM ModGuts where + + childL :: Int -> LensH ModGuts (Generic ModGuts) + childL 0 = lens $ modGutsT exposeT (childL1of2 $ \ modguts p -> modguts {mg_binds = progToBinds p}) childL n = failT (missingChild n) -- | Translate a module. -- Slightly different to the other congruence combinators: it passes in *all* of the original to the reconstruction function. -modGutsT :: TranslateH CoreProgram a -> (ModGuts -> a -> b) -> TranslateH ModGuts b -modGutsT t f = translate $ \ c modGuts -> f modGuts <$> apply t (c @@ 0) (mg_binds modGuts) +modGutsT :: TranslateH CoreProg a -> (ModGuts -> a -> b) -> TranslateH ModGuts b +modGutsT t f = translate $ \ c modGuts -> f modGuts <$> apply t (c @@ 0) (bindsToProg (mg_binds modGuts)) --- | Rewrite the 'CoreProgram' child of a module. -modGutsR :: RewriteH CoreProgram -> RewriteH ModGuts -modGutsR r = modGutsT r (\ modguts bds -> modguts {mg_binds = bds}) +-- | Rewrite the 'CoreProg' child of a module. +modGutsR :: RewriteH CoreProg -> RewriteH ModGuts +modGutsR r = modGutsT r (\ modguts p -> modguts {mg_binds = progToBinds p}) --------------------------------------------------------------------- -instance Injection CoreProgram Core where - inject = ProgramCore - retract (ProgramCore bds) = Just bds - retract _ = Nothing +instance Injection CoreProg Core where -instance Node CoreProgram where - type Generic CoreProgram = Core + inject :: CoreProg -> Core + inject = ProgCore - -- we consider only the head and tail to be interesting children - numChildren bds = min 2 (length bds) + retract :: Core -> Maybe CoreProg + retract (ProgCore bds) = Just bds + retract _ = Nothing -instance Walker Context HermitM CoreProgram where - childL 0 = lens $ consBindT exposeT idR (childL0of2 (:)) - childL 1 = lens $ consBindT idR exposeT (childL1of2 (:)) +instance Node CoreProg where + type Generic CoreProg = Core + + -- A program is either empty (zero children) or a binding group and the remaining program it scopes over (two children). + numChildren :: CoreProg -> Int + numChildren ProgNil = 0 + numChildren (ProgCons _ _) = 2 + +instance Walker HermitC HermitM CoreProg where + + childL :: Int -> LensH CoreProg (Generic CoreProg) + childL 0 = lens $ progConsT exposeT idR (childL0of2 ProgCons) + childL 1 = lens $ progConsT idR exposeT (childL1of2 ProgCons) childL n = failT (missingChild n) -- | Translate an empty list. -nilT :: b -> TranslateH [a] b -nilT b = contextfreeT $ \ e -> case e of - [] -> pure b - _ -> fail "no match for []" +progNilT :: b -> TranslateH CoreProg b +progNilT b = contextfreeT $ \case + ProgNil -> pure b + ProgCons _ _ -> fail "not an empty program node." -consBindT' :: TranslateH CoreBind a1 -> TranslateH CoreProgram a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreProgram b -consBindT' t1 t2 f = translate $ \ c e -> case e of - bd:bds -> f (apply t1 (c @@ 0) bd) (apply t2 (addBinding bd c @@ 1) bds) - _ -> fail "no match for consBind" +progConsT' :: TranslateH CoreBind a1 -> TranslateH CoreProg a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreProg b +progConsT' t1 t2 f = translate $ \ c -> \case + ProgCons bd p -> f (apply t1 (c @@ 0) bd) (apply t2 (addBinding bd c @@ 1) p) + _ -> fail "not a non-empty program node." --- | Translate a program of the form: ('CoreBind' @:@ 'CoreProgram') -consBindT :: TranslateH CoreBind a1 -> TranslateH CoreProgram a2 -> (a1 -> a2 -> b) -> TranslateH CoreProgram b -consBindT t1 t2 f = consBindT' t1 t2 (liftA2 f) +-- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg') +progConsT :: TranslateH CoreBind a1 -> TranslateH CoreProg a2 -> (a1 -> a2 -> b) -> TranslateH CoreProg b +progConsT t1 t2 f = progConsT' t1 t2 (liftA2 f) --- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProgram') -consBindAllR :: RewriteH CoreBind -> RewriteH CoreProgram -> RewriteH CoreProgram -consBindAllR r1 r2 = consBindT r1 r2 (:) +-- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProg') +progConsAllR :: RewriteH CoreBind -> RewriteH CoreProg -> RewriteH CoreProg +progConsAllR r1 r2 = progConsT r1 r2 ProgCons --- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProgram') -consBindAnyR :: RewriteH CoreBind -> RewriteH CoreProgram -> RewriteH CoreProgram -consBindAnyR r1 r2 = consBindT' (attemptR r1) (attemptR r2) (attemptAny2 (:)) +-- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProg') +progConsAnyR :: RewriteH CoreBind -> RewriteH CoreProg -> RewriteH CoreProg +progConsAnyR r1 r2 = progConsT' (attemptR r1) (attemptR r2) (attemptAny2 ProgCons) --- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProgram') -consBindOneR :: RewriteH CoreBind -> RewriteH CoreProgram -> RewriteH CoreProgram -consBindOneR r1 r2 = consBindT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 (:)) +-- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProg') +progConsOneR :: RewriteH CoreBind -> RewriteH CoreProg -> RewriteH CoreProg +progConsOneR r1 r2 = progConsT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 ProgCons) --------------------------------------------------------------------- instance Injection CoreBind Core where - inject = BindCore + + inject :: CoreBind -> Core + inject = BindCore + + retract :: Core -> Maybe CoreBind retract (BindCore bnd) = Just bnd retract _ = Nothing instance Node CoreBind where type Generic CoreBind = Core + numChildren :: CoreBind -> Int numChildren (NonRec _ _) = 1 numChildren (Rec defs) = length defs -instance Walker Context HermitM CoreBind where +instance Walker HermitC HermitM CoreBind where + + childL :: Int -> LensH CoreBind (Generic CoreBind) childL n = lens $ setFailMsg (missingChild n) $ case n of 0 -> nonrec <+ rec @@ -249,41 +278,46 @@ where nonrec = nonRecT exposeT (childL1of2 NonRec) rec = whenM (hasChildT n) $ - recT (const exposeT) (childLMofN n defToRecBind) + recT (const exposeT) (childLMofN n defsToRecBind) + allT :: Monoid b => TranslateH (Generic CoreBind) b -> TranslateH CoreBind b allT t = nonRecT (extractT t) (\ _ -> id) <+ recT (\ _ -> extractT t) mconcat + oneT :: TranslateH (Generic CoreBind) b -> TranslateH CoreBind b oneT t = nonRecT (extractT t) (\ _ -> id) <+ recT' (\ _ -> extractT t) catchesM + allR :: RewriteH (Generic CoreBind) -> RewriteH CoreBind allR r = nonRecR (extractR r) <+ recAllR (\ _ -> extractR r) + anyR :: RewriteH (Generic CoreBind) -> RewriteH CoreBind anyR r = nonRecR (extractR r) <+ recAnyR (\ _ -> extractR r) + oneR :: RewriteH (Generic CoreBind) -> RewriteH CoreBind oneR r = nonRecR (extractR r) <+ recOneR (\ _ -> extractR r) --- | Translate a binding group of the form: @NonRec@ 'Id' 'CoreExpr' -nonRecT :: TranslateH CoreExpr a -> (Id -> a -> b) -> TranslateH CoreBind b -nonRecT t f = translate $ \ c e -> case e of - NonRec v e' -> f v <$> apply t (c @@ 0) e' - _ -> fail "not NonRec constructor" +-- | Translate a binding group of the form: @NonRec@ 'Var' 'CoreExpr' +nonRecT :: TranslateH CoreExpr a -> (Var -> a -> b) -> TranslateH CoreBind b +nonRecT t f = translate $ \ c -> \case + NonRec v e -> f v <$> apply t (c @@ 0) e + _ -> fail "not a non-recursive binding-group node." --- | Rewrite the 'CoreExpr' child of a binding group of the form: @NonRec@ 'Id' 'CoreExpr' +-- | Rewrite the 'CoreExpr' child of a binding group of the form: @NonRec@ 'Var' 'CoreExpr' nonRecR :: RewriteH CoreExpr -> RewriteH CoreBind nonRecR r = nonRecT r NonRec recT' :: (Int -> TranslateH CoreDef a) -> ([HermitM a] -> HermitM b) -> TranslateH CoreBind b -recT' t f = translate $ \ c e -> case e of - Rec bds -> -- Notice how we add the scoping bindings here *before* decending into each individual definition. +recT' t f = translate $ \ c -> \case + Rec bds -> -- Notice how we add the scoping bindings here *before* descending into each individual definition. let c' = addBinding (Rec bds) c - in f [ apply (t n) (c' @@ n) (Def v e') -- here we convert from (Id,CoreExpr) to CoreDef - | ((v,e'),n) <- zip bds [0..] + in f [ apply (t n) (c' @@ n) (Def v e) -- here we convert from (Id,CoreExpr) to CoreDef + | ((v,e),n) <- zip bds [0..] ] - _ -> fail "not Rec constructor" + _ -> fail "not a recursive binding-group node." -- | Translate a binding group of the form: @Rec@ ['CoreDef'] recT :: (Int -> TranslateH CoreDef a) -> ([a] -> b) -> TranslateH CoreBind b @@ -291,29 +325,36 @@ -- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef'] recAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreBind -recAllR rs = recT rs defToRecBind +recAllR rs = recT rs defsToRecBind -- | Rewrite any children of a binding group of the form: @Rec@ ['CoreDef'] recAnyR :: (Int -> RewriteH CoreDef) -> RewriteH CoreBind -recAnyR rs = recT' (attemptR . rs) (attemptAnyN defToRecBind) +recAnyR rs = recT' (attemptR . rs) (attemptAnyN defsToRecBind) -- | Rewrite one child of a binding group of the form: @Rec@ ['CoreDef'] recOneR :: (Int -> RewriteH CoreDef) -> RewriteH CoreBind -recOneR rs = recT' (withArgumentT . rs) (attemptOneN defToRecBind) +recOneR rs = recT' (withArgumentT . rs) (attemptOneN defsToRecBind) --------------------------------------------------------------------- instance Injection CoreDef Core where - inject = DefCore + + inject :: CoreDef -> Core + inject = DefCore + + retract :: Core -> Maybe CoreDef retract (DefCore def) = Just def retract _ = Nothing instance Node CoreDef where type Generic CoreDef = Core + numChildren :: CoreDef -> Int numChildren _ = 1 -instance Walker Context HermitM CoreDef where +instance Walker HermitC HermitM CoreDef where + + childL :: Int -> LensH CoreDef (Generic CoreDef) childL 0 = lens $ defT exposeT (childL1of2 Def) childL n = failT (missingChild n) @@ -328,16 +369,23 @@ --------------------------------------------------------------------- instance Injection CoreAlt Core where - inject = AltCore + + inject :: CoreAlt -> Core + inject = AltCore + + retract :: Core -> Maybe CoreAlt retract (AltCore expr) = Just expr retract _ = Nothing instance Node CoreAlt where type Generic CoreAlt = Core + numChildren :: CoreAlt -> Int numChildren _ = 1 -instance Walker Context HermitM CoreAlt where +instance Walker HermitC HermitM CoreAlt where + + childL :: Int -> LensH CoreAlt (Generic CoreAlt) childL 0 = lens $ altT exposeT (childL2of3 (,,)) childL n = failT (missingChild n) @@ -352,13 +400,18 @@ --------------------------------------------------------------------- instance Injection CoreExpr Core where - inject = ExprCore + + inject :: CoreExpr -> Core + inject = ExprCore + + retract :: Core -> Maybe CoreExpr retract (ExprCore expr) = Just expr retract _ = Nothing instance Node CoreExpr where type Generic CoreExpr = Core + numChildren :: CoreExpr -> Int numChildren (Var _) = 0 numChildren (Lit _) = 0 numChildren (App _ _) = 2 @@ -370,8 +423,9 @@ numChildren (Type _) = 0 numChildren (Coercion _) = 0 -instance Walker Context HermitM CoreExpr where +instance Walker HermitC HermitM CoreExpr where + childL :: Int -> LensH CoreExpr (Generic CoreExpr) childL n = lens $ setFailMsg (missingChild n) $ case n of 0 -> appT exposeT idR (childL0of2 App) @@ -391,6 +445,7 @@ caseChooseL = whenM (hasChildT n) $ caseT idR (const exposeT) (\ e v t -> childLMofN (n-1) (Case e v t)) + allT :: Monoid b => TranslateH (Generic CoreExpr) b -> TranslateH CoreExpr b allT t = varT (\ _ -> mempty) <+ litT (\ _ -> mempty) <+ appT (extractT t) (extractT t) mappend @@ -402,6 +457,7 @@ <+ typeT (\ _ -> mempty) <+ coercionT (\ _ -> mempty) + oneT :: TranslateH (Generic CoreExpr) b -> TranslateH CoreExpr b oneT t = appT' (extractT t) (extractT t) (<<+) <+ lamT (extractT t) (\ _ -> id) <+ letT' (extractT t) (extractT t) (<<+) @@ -409,6 +465,7 @@ <+ castT (extractT t) const <+ tickT (extractT t) (\ _ -> id) + allR :: RewriteH (Generic CoreExpr) -> RewriteH CoreExpr allR r = varT Var <+ litT Lit <+ appAllR (extractR r) (extractR r) @@ -420,6 +477,7 @@ <+ typeT Type <+ coercionT Coercion + anyR :: RewriteH (Generic CoreExpr) -> RewriteH CoreExpr anyR r = appAnyR (extractR r) (extractR r) <+ lamR (extractR r) <+ letAnyR (extractR r) (extractR r) @@ -428,6 +486,7 @@ <+ tickR (extractR r) <+ fail "anyR failed" + oneR :: RewriteH (Generic CoreExpr) -> RewriteH CoreExpr oneR r = appOneR (extractR r) (extractR r) <+ lamR (extractR r) <+ letOneR (extractR r) (extractR r) @@ -438,23 +497,23 @@ --------------------------------------------------------------------- --- | Translate an expression of the form: @Var@ 'Id' -varT :: (Id -> b) -> TranslateH CoreExpr b -varT f = contextfreeT $ \ e -> case e of - Var v -> pure (f v) - _ -> fail "no match for Var" +-- | Translate an expression of the form: @Var@ 'Var' +varT :: (Var -> b) -> TranslateH CoreExpr b +varT f = contextfreeT $ \case + Var v -> pure (f v) + _ -> fail "not a variable node." -- | Translate an expression of the form: @Lit@ 'Literal' litT :: (Literal -> b) -> TranslateH CoreExpr b -litT f = contextfreeT $ \ e -> case e of - Lit x -> pure (f x) - _ -> fail "no match for Lit" +litT f = contextfreeT $ \case + Lit x -> pure (f x) + _ -> fail "not a literal node." appT' :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreExpr b -appT' t1 t2 f = translate $ \ c e -> case e of - App e1 e2 -> f (apply t1 (c @@ 0) e1) (apply t2 (c @@ 1) e2) - _ -> fail "no match for App" +appT' t1 t2 f = translate $ \ c -> \case + App e1 e2 -> f (apply t1 (c @@ 0) e1) (apply t2 (c @@ 1) e2) + _ -> fail "not an application node." -- | Translate an expression of the form: @App@ 'CoreExpr' 'CoreExpr' appT :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (a1 -> a2 -> b) -> TranslateH CoreExpr b @@ -472,23 +531,23 @@ appOneR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr appOneR r1 r2 = appT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 App) --- | Translate an expression of the form: @Lam@ 'Id' 'CoreExpr' -lamT :: TranslateH CoreExpr a -> (Id -> a -> b) -> TranslateH CoreExpr b -lamT t f = translate $ \ c e -> case e of - Lam b e1 -> f b <$> apply t (addLambdaBinding b c @@ 0) e1 - _ -> fail "no match for Lam" +-- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr' +lamT :: TranslateH CoreExpr a -> (Var -> a -> b) -> TranslateH CoreExpr b +lamT t f = translate $ \ c -> \case + Lam b e -> f b <$> apply t (addLambdaBinding b c @@ 0) e + _ -> fail "not a lambda node." --- | Rewrite the 'CoreExpr' child of an expression of the form: @Lam@ 'Id' 'CoreExpr' +-- | Rewrite the 'CoreExpr' child of an expression of the form: @Lam@ 'Var' 'CoreExpr' lamR :: RewriteH CoreExpr -> RewriteH CoreExpr lamR r = lamT r Lam letT' :: TranslateH CoreBind a1 -> TranslateH CoreExpr a2 -> (HermitM a1 -> HermitM a2 -> HermitM b) -> TranslateH CoreExpr b -letT' t1 t2 f = translate $ \ c e -> case e of - Let bds e1 -> f (apply t1 (c @@ 0) bds) (apply t2 (addBinding bds c @@ 1) e1) +letT' t1 t2 f = translate $ \ c -> \case + Let bds e -> f (apply t1 (c @@ 0) bds) (apply t2 (addBinding bds c @@ 1) e) -- use *original* env, because the bindings are self-binding, -- if they are recursive. See recT'. - _ -> fail "no match for Let" + _ -> fail "not a let node." -- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr' letT :: TranslateH CoreBind a1 -> TranslateH CoreExpr a2 -> (a1 -> a2 -> b) -> TranslateH CoreExpr b @@ -507,21 +566,15 @@ letOneR r1 r2 = letT' (withArgumentT r1) (withArgumentT r2) (attemptOne2 Let) -caseT' :: TranslateH CoreExpr a1 - -> (Int -> TranslateH CoreAlt a2) - -> (Id -> Type -> HermitM a1 -> [HermitM a2] -> HermitM b) - -> TranslateH CoreExpr b -caseT' t ts f = translate $ \ c e -> case e of - Case e1 b ty alts -> f b ty (apply t (c @@ 0) e1) $ [ apply (ts n) (addCaseBinding (b,e1,alt) c @@ (n+1)) alt - | (alt,n) <- zip alts [0..] - ] - _ -> fail "no match for Case" +caseT' :: TranslateH CoreExpr a1 -> (Int -> TranslateH CoreAlt a2) -> (Id -> Type -> HermitM a1 -> [HermitM a2] -> HermitM b) -> TranslateH CoreExpr b +caseT' t ts f = translate $ \ c -> \case + Case e b ty alts -> f b ty (apply t (c @@ 0) e) $ [ apply (ts n) (addCaseBinding (b,e,alt) c @@ (n+1)) alt + | (alt,n) <- zip alts [0..] + ] + _ -> fail "not a case node." -- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] -caseT :: TranslateH CoreExpr a1 - -> (Int -> TranslateH CoreAlt a2) - -> (a1 -> Id -> Type -> [a2] -> b) - -> TranslateH CoreExpr b +caseT :: TranslateH CoreExpr a1 -> (Int -> TranslateH CoreAlt a2) -> (a1 -> Id -> Type -> [a2] -> b) -> TranslateH CoreExpr b caseT t ts f = caseT' t ts (\ b ty me malts -> f <$> me <*> pure b <*> pure ty <*> sequence malts) -- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] @@ -538,9 +591,9 @@ -- | Translate an expression of the form: @Cast@ 'CoreExpr' 'Coercion' castT :: TranslateH CoreExpr a -> (a -> Coercion -> b) -> TranslateH CoreExpr b -castT t f = translate $ \ c e -> case e of - Cast e1 cast -> f <$> apply t (c @@ 0) e1 <*> pure cast - _ -> fail "no match for Cast" +castT t f = translate $ \ c -> \case + Cast e cast -> f <$> apply t (c @@ 0) e <*> pure cast + _ -> fail "not a cast node." -- | Rewrite the 'CoreExpr' child of an expression of the form: @Cast@ 'CoreExpr' 'Coercion' castR :: RewriteH CoreExpr -> RewriteH CoreExpr @@ -548,9 +601,9 @@ -- | Translate an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr' tickT :: TranslateH CoreExpr a -> (CoreTickish -> a -> b) -> TranslateH CoreExpr b -tickT t f = translate $ \ c e -> case e of - Tick tk e1 -> f tk <$> apply t (c @@ 0) e1 - _ -> fail "no match for Tick" +tickT t f = translate $ \ c -> \case + Tick tk e -> f tk <$> apply t (c @@ 0) e + _ -> fail "not a tick node." -- | Rewrite the 'CoreExpr' child of an expression of the form: @Tick@ 'CoreTickish' 'CoreExpr' tickR :: RewriteH CoreExpr -> RewriteH CoreExpr @@ -558,15 +611,15 @@ -- | Translate an expression of the form: @Type@ 'Type' typeT :: (Type -> b) -> TranslateH CoreExpr b -typeT f = contextfreeT $ \ e -> case e of - Type t -> pure (f t) - _ -> fail "no match for Type" +typeT f = contextfreeT $ \case + Type t -> pure (f t) + _ -> fail "not a type node." -- | Translate an expression of the form: @Coercion@ 'Coercion' coercionT :: (Coercion -> b) -> TranslateH CoreExpr b -coercionT f = contextfreeT $ \ e -> case e of - Coercion co -> pure (f co) - _ -> fail "no match for Coercion" +coercionT f = contextfreeT $ \case + Coercion co -> pure (f co) + _ -> fail "not a coercion node." --------------------------------------------------------------------- @@ -589,70 +642,70 @@ recDefOneR rs = recOneR (\ n -> defR (rs n)) --- | Translate a program of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram' -consNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreProgram a2 -> (Id -> a1 -> a2 -> b) -> TranslateH CoreProgram b -consNonRecT t1 t2 f = consBindT (nonRecT t1 (,)) t2 (uncurry f) +-- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' +consNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreProg a2 -> (Var -> a1 -> a2 -> b) -> TranslateH CoreProg b +consNonRecT t1 t2 f = progConsT (nonRecT t1 (,)) t2 (uncurry f) --- | Rewrite all children of an expression of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram' -consNonRecAllR :: RewriteH CoreExpr -> RewriteH CoreProgram -> RewriteH CoreProgram -consNonRecAllR r1 r2 = consBindAllR (nonRecR r1) r2 +-- | Rewrite all children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' +consNonRecAllR :: RewriteH CoreExpr -> RewriteH CoreProg -> RewriteH CoreProg +consNonRecAllR r1 r2 = progConsAllR (nonRecR r1) r2 --- | Rewrite any children of an expression of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram' -consNonRecAnyR :: RewriteH CoreExpr -> RewriteH CoreProgram -> RewriteH CoreProgram -consNonRecAnyR r1 r2 = consBindAnyR (nonRecR r1) r2 +-- | Rewrite any children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' +consNonRecAnyR :: RewriteH CoreExpr -> RewriteH CoreProg -> RewriteH CoreProg +consNonRecAnyR r1 r2 = progConsAnyR (nonRecR r1) r2 --- | Rewrite one child of an expression of the form: (@NonRec@ 'Id' 'CoreExpr') @:@ 'CoreProgram' -consNonRecOneR :: RewriteH CoreExpr -> RewriteH CoreProgram -> RewriteH CoreProgram -consNonRecOneR r1 r2 = consBindOneR (nonRecR r1) r2 +-- | Rewrite one child of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' +consNonRecOneR :: RewriteH CoreExpr -> RewriteH CoreProg -> RewriteH CoreProg +consNonRecOneR r1 r2 = progConsOneR (nonRecR r1) r2 --- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram' -consRecT :: (Int -> TranslateH CoreDef a1) -> TranslateH CoreProgram a2 -> ([a1] -> a2 -> b) -> TranslateH CoreProgram b -consRecT ts t = consBindT (recT ts id) t +-- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' +consRecT :: (Int -> TranslateH CoreDef a1) -> TranslateH CoreProg a2 -> ([a1] -> a2 -> b) -> TranslateH CoreProg b +consRecT ts t = progConsT (recT ts id) t --- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram' -consRecAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProgram -> RewriteH CoreProgram -consRecAllR rs r = consBindAllR (recAllR rs) r +-- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' +consRecAllR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProg -> RewriteH CoreProg +consRecAllR rs r = progConsAllR (recAllR rs) r --- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram' -consRecAnyR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProgram -> RewriteH CoreProgram -consRecAnyR rs r = consBindAnyR (recAnyR rs) r +-- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' +consRecAnyR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProg -> RewriteH CoreProg +consRecAnyR rs r = progConsAnyR (recAnyR rs) r --- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProgram' -consRecOneR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProgram -> RewriteH CoreProgram -consRecOneR rs r = consBindOneR (recOneR rs) r +-- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' +consRecOneR :: (Int -> RewriteH CoreDef) -> RewriteH CoreProg -> RewriteH CoreProg +consRecOneR rs r = progConsOneR (recOneR rs) r --- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram' -consRecDefT :: (Int -> TranslateH CoreExpr a1) -> TranslateH CoreProgram a2 -> ([(Id,a1)] -> a2 -> b) -> TranslateH CoreProgram b +-- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' +consRecDefT :: (Int -> TranslateH CoreExpr a1) -> TranslateH CoreProg a2 -> ([(Id,a1)] -> a2 -> b) -> TranslateH CoreProg b consRecDefT ts t = consRecT (\ n -> defT (ts n) (,)) t --- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram' -consRecDefAllR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProgram -> RewriteH CoreProgram +-- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' +consRecDefAllR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProg -> RewriteH CoreProg consRecDefAllR rs r = consRecAllR (\ n -> defR (rs n)) r --- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram' -consRecDefAnyR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProgram -> RewriteH CoreProgram +-- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' +consRecDefAnyR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProg -> RewriteH CoreProg consRecDefAnyR rs r = consRecAnyR (\ n -> defR (rs n)) r --- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProgram' -consRecDefOneR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProgram -> RewriteH CoreProgram +-- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' +consRecDefOneR :: (Int -> RewriteH CoreExpr) -> RewriteH CoreProg -> RewriteH CoreProg consRecDefOneR rs r = consRecOneR (\ n -> defR (rs n)) r --- | Translate an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr' -letNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (Id -> a1 -> a2 -> b) -> TranslateH CoreExpr b +-- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' +letNonRecT :: TranslateH CoreExpr a1 -> TranslateH CoreExpr a2 -> (Var -> a1 -> a2 -> b) -> TranslateH CoreExpr b letNonRecT t1 t2 f = letT (nonRecT t1 (,)) t2 (uncurry f) --- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr' +-- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecAllR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr letNonRecAllR r1 r2 = letAllR (nonRecR r1) r2 --- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr' +-- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecAnyR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr letNonRecAnyR r1 r2 = letAnyR (nonRecR r1) r2 --- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Id' 'CoreExpr') 'CoreExpr' +-- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' letNonRecOneR :: RewriteH CoreExpr -> RewriteH CoreExpr -> RewriteH CoreExpr letNonRecOneR r1 r2 = letOneR (nonRecR r1) r2 @@ -713,9 +766,9 @@ promoteModGutsR :: RewriteH ModGuts -> RewriteH Core promoteModGutsR = promoteWithFailMsgR "This rewrite can only succeed at the module level." --- | Promote a rewrite on 'CoreProgram' to a rewrite on 'Core'. -promoteProgramR :: RewriteH CoreProgram -> RewriteH Core -promoteProgramR = promoteWithFailMsgR "This rewrite can only succeed at program nodes (the top-level)." +-- | Promote a rewrite on 'CoreProg' to a rewrite on 'Core'. +promoteProgR :: RewriteH CoreProg -> RewriteH Core +promoteProgR = promoteWithFailMsgR "This rewrite can only succeed at program nodes (the top-level)." -- | Promote a rewrite on 'CoreBind' to a rewrite on 'Core'. promoteBindR :: RewriteH CoreBind -> RewriteH Core @@ -739,9 +792,9 @@ promoteModGutsT :: TranslateH ModGuts b -> TranslateH Core b promoteModGutsT = promoteWithFailMsgT "This translate can only succeed at the module level." --- | Promote a translate on 'CoreProgram' to a translate on 'Core'. -promoteProgramT :: TranslateH CoreProgram b -> TranslateH Core b -promoteProgramT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)." +-- | Promote a translate on 'CoreProg' to a translate on 'Core'. +promoteProgT :: TranslateH CoreProg b -> TranslateH Core b +promoteProgT = promoteWithFailMsgT "This translate can only succeed at program nodes (the top-level)." -- | Promote a translate on 'CoreBind' to a translate on 'Core'. promoteBindT :: TranslateH CoreBind b -> TranslateH Core b diff --git a/src/Language/HERMIT/Monad.hs b/src/Language/HERMIT/Monad.hs --- a/src/Language/HERMIT/Monad.hs +++ b/src/Language/HERMIT/Monad.hs @@ -6,15 +6,18 @@ HermitM , runHM , liftCoreM - , newVarH - , newTypeVarH - , cloneIdH + , newIdH + , newTyVarH + -- , newVarExprH + -- , newVarH + , cloneVarH -- * Saving Definitions , Label , DefStash , saveDef , lookupDef , getStash + -- * Messages , HermitMEnv(..) , DebugMessage(..) , mkHermitMEnv @@ -34,7 +37,7 @@ import Language.KURE.Combinators import Language.KURE.Utilities -import Language.HERMIT.CoreExtra +import Language.HERMIT.Core import Language.HERMIT.Context ---------------------------------------------------------------------------- @@ -49,14 +52,16 @@ newtype HermitMEnv = HermitMEnv { hs_debugChan :: DebugMessage -> HermitM () } -- | The HERMIT monad is kept abstract. -newtype HermitM a = HermitM (HermitMEnv -> DefStash -> CoreM (KureMonad (DefStash, a))) +newtype HermitM a = HermitM (HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a))) -runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureMonad (DefStash, a)) +runHermitM :: HermitM a -> HermitMEnv -> DefStash -> CoreM (KureM (DefStash, a)) runHermitM (HermitM f) = f +-- | Get the stash of saved definitions. getStash :: HermitM DefStash getStash = HermitM (\ _ s -> return $ return (s, s)) +-- | Replace the stash of saved definitions. putStash :: DefStash -> HermitM () putStash s = HermitM (\ _ _ -> return $ return (s, ())) @@ -75,7 +80,7 @@ -- | Eliminator for 'HermitM'. runHM :: HermitMEnv -> DefStash -> (DefStash -> a -> CoreM b) -> (String -> CoreM b) -> HermitM a -> CoreM b -runHM env s success failure ma = runHermitM ma env s >>= runKureMonad (\ (a,b) -> success a b) failure +runHM env s success failure ma = runHermitM ma env s >>= runKureM (\ (a,b) -> success a b) failure ---------------------------------------------------------------------------- @@ -85,7 +90,7 @@ instance Applicative HermitM where pure :: a -> HermitM a - pure = return + pure = return (<*>) :: HermitM (a -> b) -> HermitM a -> HermitM b (<*>) = ap @@ -95,14 +100,14 @@ return a = HermitM $ \ _ s -> return (return (s,a)) (>>=) :: HermitM a -> (a -> HermitM b) -> HermitM b - (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureMonad (\ (s', a) -> runHermitM (f a) env s') (return . fail) + (HermitM gcm) >>= f = HermitM $ \ env -> gcm env >=> runKureM (\ (s', a) -> runHermitM (f a) env s') (return . fail) fail :: String -> HermitM a fail msg = HermitM $ \ _ _ -> return (fail msg) instance MonadCatch HermitM where catchM :: HermitM a -> (String -> HermitM a) -> HermitM a - (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureMonad (return.return) (\ msg -> runHermitM (f msg) env s) + (HermitM gcm) `catchM` f = HermitM $ \ env s -> gcm env s >>= runKureM (return.return) (\ msg -> runHermitM (f msg) env s) ---------------------------------------------------------------------------- @@ -130,39 +135,48 @@ ---------------------------------------------------------------------------- newName :: String -> HermitM Name -newName name = do - uq <- getUniqueM - return $ mkSystemVarName uq $ mkFastString $ name +newName name = do uq <- getUniqueM + return $ mkSystemVarName uq $ mkFastString name -- | Make a unique identifier for a specified type based on a provided name. -newVarH :: String -> Type -> HermitM Id -newVarH name ty = do - name' <- newName name - return $ mkLocalId name' ty +newIdH :: String -> Type -> HermitM Id +newIdH name ty = do name' <- newName name + return $ mkLocalId name' ty -- | Make a unique type variable for a specified kind based on a provided name. -newTypeVarH :: String -> Kind -> HermitM TyVar -newTypeVarH name kind = do - name' <- newName name - return $ mkTyVar name' kind +newTyVarH :: String -> Kind -> HermitM TyVar +newTyVarH name kind = do name' <- newName name + return $ mkTyVar name' kind +-- Not sure whether this would be useful or not. +-- Make either a new identifier of a given type, or type variable of a given kind. +-- Note that as 'Id' and 'TyVar' are synonyms of 'Var', and 'Kind' is a synonym of 'Type', +-- the choice is determined entirely by the 'Either' constructor. +-- newVarH :: String -> Either Type Kind -> HermitM Var +-- newVarH name = either (newIdH name) (newTypeVarH name) --- This gives an new version of an Id, with the same info, and a new textual name. -cloneIdH :: (String -> String) -> Id -> HermitM Id -cloneIdH nameMod b = - let name = nameMod $ getOccString b - ty = idType b +-- Make either a new identifier of a given type, or type variable of a given kind, +-- and wrap it in a 'Var' or 'Type' constructor, respectively. +-- newVarExprH :: String -> Either Type Kind -> HermitM CoreExpr +-- newVarExprH str (Left ty) = Var <$> newIdH str ty +-- newVarExprH str (Right k) = (Type . mkTyVarTy) <$> newTypeVarH str k + +-- | This gives an new version of a 'Var', with the same info, and a new textual name. +cloneVarH :: (String -> String) -> Var -> HermitM Var +cloneVarH nameMod v = + let name = nameMod (getOccString v) + ty = varType v in - if isTyVar b - then newTypeVarH name ty - else newVarH name ty + if isTyVar v + then newTyVarH name ty + else newIdH name ty ---------------------------------------------------------------------------- -- | A message packet. data DebugMessage :: * where DebugTick :: String -> DebugMessage - DebugCore :: String -> Context -> Core -> DebugMessage -- A postcard + DebugCore :: String -> HermitC -> Core -> DebugMessage -- A postcard mkHermitMEnv :: (DebugMessage -> HermitM ()) -> HermitMEnv mkHermitMEnv debugger = HermitMEnv diff --git a/src/Language/HERMIT/Plugin.hs b/src/Language/HERMIT/Plugin.hs --- a/src/Language/HERMIT/Plugin.hs +++ b/src/Language/HERMIT/Plugin.hs @@ -8,9 +8,22 @@ import Data.List import System.IO +import Data.Char (isDigit) +import Data.Default + -- | Given a list of 'CommandLineOption's, produce the 'ModGuts' to 'ModGuts' function required to build a plugin. type HermitPass = [CommandLineOption] -> ModGuts -> CoreM ModGuts +data Options = Options { pass :: Int } + +instance Default Options where + def = Options { pass = 0 } + +parse :: [String] -> Options -> Options +parse (('-':'p':n):rest) o | all isDigit n = parse rest $ o { pass = read n } +parse (_:rest) o = parse rest o -- unknown option +parse [] o = o + -- | Build a hermit plugin. This mainly handles the per-module options. hermitPlugin :: HermitPass -> Plugin hermitPlugin hp = defaultPlugin { installCoreToDos = install } @@ -24,17 +37,18 @@ dynFlags <- getDynFlags - let - myPass = CoreDoPluginPass "HERMIT" $ modFilter dynFlags hp opts + let (m_opts, h_opts) = partition (isInfixOf ":") opts + hermit_opts = parse h_opts def + myPass = CoreDoPluginPass "HERMIT" $ modFilter dynFlags hp m_opts -- at front, for now - allPasses = myPass : todos + allPasses = insertAt (pass hermit_opts) myPass todos return allPasses -- | Determine whether to act on this module, choose plugin pass. modFilter :: DynFlags -> HermitPass -> HermitPass modFilter dynFlags hp opts guts | null modOpts && not (null opts) = return guts -- don't process this module - | otherwise = hp modOpts guts + | otherwise = hp modOpts guts where modOpts = filterOpts dynFlags opts guts -- | Filter options to those pertaining to this module, stripping module prefix. @@ -42,3 +56,7 @@ filterOpts dynFlags opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ] where modName = showPpr dynFlags $ mg_module guts len = length modName + 1 -- for the colon + +insertAt :: Int -> a -> [a] -> [a] +insertAt n x xs = pre ++ (x : suf) + where (pre,suf) = splitAt n xs diff --git a/src/Language/HERMIT/PrettyPrinter.hs b/src/Language/HERMIT/PrettyPrinter.hs --- a/src/Language/HERMIT/PrettyPrinter.hs +++ b/src/Language/HERMIT/PrettyPrinter.hs @@ -6,6 +6,7 @@ import Text.PrettyPrint.MarkedHughesPJ as PP import Language.HERMIT.Kure +import Language.HERMIT.Core import Control.Arrow import Data.Monoid hiding ((<>)) import Data.Default @@ -232,7 +233,7 @@ ghcCorePrettyH :: PrettyH Core ghcCorePrettyH = promoteT (ppModule :: PrettyH ModGuts) - <+ promoteT (ppH :: PrettyH CoreProgram) + <+ promoteT (ppProg :: PrettyH CoreProg) <+ promoteT (ppH :: PrettyH CoreBind) <+ promoteT (ppDef :: PrettyH CoreDef) <+ promoteT (ppH :: PrettyH CoreExpr) @@ -247,8 +248,11 @@ ppModule :: PrettyH ModGuts ppModule = mg_module ^>> ppH + ppProg :: PrettyH CoreProg + ppProg = progToBinds ^>> ppH + ppDef :: PrettyH CoreDef - ppDef = (\ (Def v e) -> (v,e)) ^>> ppH + ppDef = defToIdExpr ^>> ppH -- arr (PP.text . ppr . mg_module) diff --git a/src/Language/HERMIT/PrettyPrinter/AST.hs b/src/Language/HERMIT/PrettyPrinter/AST.hs --- a/src/Language/HERMIT/PrettyPrinter/AST.hs +++ b/src/Language/HERMIT/PrettyPrinter/AST.hs @@ -8,6 +8,7 @@ import qualified GhcPlugins as GHC import Language.HERMIT.Kure +import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter import Text.PrettyPrint.MarkedHughesPJ as PP @@ -37,9 +38,10 @@ ppModGuts :: PrettyH GHC.ModGuts ppModGuts = arr (ppSDoc . GHC.mg_module) - -- DocH is not a monoid, so we can't use listT here - ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind] - ppProgram = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c) + -- DocH is not a monoid. + -- GHC uses a list, which we print here. The CoreProg type is our doing. + ppCoreProg :: PrettyH CoreProg + ppCoreProg = translate $ \ c -> fmap vlist . sequenceA . map (apply ppCoreBind c) . progToBinds ppCoreExpr :: PrettyH GHC.CoreExpr ppCoreExpr = varT (\i -> text "Var" <+> varColor (ppSDoc i)) @@ -71,7 +73,7 @@ ppCoreDef = defT ppCoreExpr $ \ i e -> parens $ varColor (ppSDoc i) <> text "," <> e promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr) - <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram) + <+ promoteT (ppCoreProg :: PrettyH CoreProg) <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind) <+ promoteT (ppCoreDef :: PrettyH CoreDef) <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts) diff --git a/src/Language/HERMIT/PrettyPrinter/Clean.hs b/src/Language/HERMIT/PrettyPrinter/Clean.hs --- a/src/Language/HERMIT/PrettyPrinter/Clean.hs +++ b/src/Language/HERMIT/PrettyPrinter/Clean.hs @@ -8,9 +8,12 @@ import qualified GhcPlugins as GHC import Language.HERMIT.Kure +import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter import Language.HERMIT.GHC +import TypeRep (TyLit(..)) + import Text.PrettyPrint.MarkedHughesPJ as PP listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a @@ -52,7 +55,7 @@ normalExpr :: RetExpr -> DocH normalExpr (RetLam vs e0) = hang (specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0 -normalExpr (RetLet vs e0) = sep [ keywordColor (text "let") <+> vcat vs, keywordColor (text "in") <+> e0 ] +normalExpr (RetLet vs e0) = sep [ keyword "let" <+> vcat vs, keyword "in" <+> e0 ] normalExpr (RetApp fn xs) = sep [ hsep (fn : map atomExpr (takeWhile isAtom xs)) , nest 2 (sep (map atomExpr (dropWhile isAtom xs))) ] normalExpr (RetExpr e0) = e0 @@ -71,26 +74,41 @@ let hideNotes = True + optional :: Maybe DocH -> (DocH -> DocH) -> DocH + optional Nothing _ = empty + optional (Just d) k = k d + ppVar :: GHC.Var -> DocH ppVar = ppName . GHC.varName ppName :: GHC.Name -> DocH - ppName nm - | isInfix name = ppParens $ varColor $ text name - | otherwise = varColor $ text name + ppName = ppName' True + + ppVar' :: Bool -> GHC.Var -> DocH + ppVar' useVarColor = ppName' useVarColor . GHC.varName + + ppName' :: Bool -> GHC.Name -> DocH + ppName' useVarColor nm + | isInfix name = ppParens $ markColor color $ text name + | otherwise = markColor color $ text name where name = GHC.occNameString $ GHC.nameOccName $ nm isInfix = all (\ n -> n `elem` "!@#$%^&*-._+=:?/\\<>'") + color = if useVarColor then VarColor else TypeColor + ppLitTy :: Bool -> TyLit -> DocH + ppLitTy useVarColor tylit = markColor color $ text $ case tylit of + NumTyLit i -> show i + StrTyLit fs -> show fs + where color = if useVarColor then VarColor else TypeColor + -- binders are vars that is bound by lambda or case, etc. ppBinder :: GHC.Var -> Maybe DocH - ppBinder var = case po_exprTypes opts of - Abstract | GHC.isTyVar var -> Just $ typeBindSymbol - Omit | GHC.isTyVar var -> Nothing - _ -> Just $ ppVar var - - ppIdBinder :: GHC.Id -> DocH - ppIdBinder var = ppVar var + ppBinder var | GHC.isTyVar var = case po_exprTypes opts of + Abstract -> Just $ typeBindSymbol + Omit -> Nothing + _ -> Just $ ppVar' False var + | otherwise = Just $ ppVar var -- Use for any GHC structure, the 'showSDoc' prefix is to remind us -- that we are eliding infomation here. @@ -101,16 +119,17 @@ ppModGuts :: PrettyH GHC.ModGuts ppModGuts = arr $ \ m -> hang (keyword "module" <+> ppSDoc (GHC.mg_module m) <+> keyword "where") 2 - (vcat [ (ppIdBinder v <+> specialSymbol TypeOfSymbol <+> ppCoreType (GHC.idType v)) + (vcat [ (optional (ppBinder v) (\b -> b <+> specialSymbol TypeOfSymbol <+> ppCoreType True (GHC.idType v))) | bnd <- GHC.mg_binds m , v <- case bnd of GHC.NonRec f _ -> [f] GHC.Rec bnds -> map fst bnds ]) - -- DocH is not a monoid, so we can't use listT here - ppProgram :: PrettyH GHC.CoreProgram -- CoreProgram = [CoreBind] - ppProgram = translate $ \ c -> fmap vcat . sequenceA . map (apply ppCoreBind c) + -- DocH is not a monoid. + -- GHC uses a list, which we print here. The CoreProg type is our doing. + ppCoreProg :: PrettyH CoreProg + ppCoreProg = translate $ \ c -> fmap vcat . sequenceA . map (apply ppCoreBind c) . progToBinds ppCoreExpr :: PrettyH GHC.CoreExpr ppCoreExpr = ppCoreExprR >>^ normalExpr @@ -167,27 +186,30 @@ <+ varT (\ i p -> RetAtom (attrP p $ ppVar i)) <+ litT (\ i p -> RetAtom (attrP p $ ppSDoc i)) <+ typeT (\ t p -> case po_exprTypes opts of - Show -> RetAtom (attrP p $ ppCoreType t) + Show -> RetAtom (attrP p $ ppCoreType False t) Abstract -> RetAtom (attrP p $ typeSymbol) Omit -> RetEmpty) <+ (ppCoreExpr0 >>^ \ e p -> RetExpr (attrP p e)) - ppCoreType :: GHC.Type -> DocH - ppCoreType = normalExpr . go - where go (TyVarTy v) = RetAtom $ ppVar v - go (AppTy t1 t2) = RetExpr $ ppCoreType t1 <+> ppCoreType t2 + ppCoreType :: Bool -> GHC.Type -> DocH + ppCoreType isTySig = normalExpr . go + where go (TyVarTy v) = RetAtom $ ppVar' isTySig v + go (LitTy tylit) = RetAtom $ ppLitTy isTySig tylit + go (AppTy t1 t2) = RetExpr $ ppCoreType isTySig t1 <+> ppCoreType isTySig t2 go (TyConApp tyCon tys) | GHC.isFunTyCon tyCon, [ty1,ty2] <- tys = go (FunTy ty1 ty2) - | GHC.isTupleTyCon tyCon = case map ppCoreType tys of - [] -> RetAtom $ text "()" - ds -> RetExpr $ text "(" <> (foldr1 (\d r -> d <> text "," <+> r) ds) <> text ")" - | otherwise = RetAtom $ ppName (GHC.getName tyCon) <+> sep (map ppCoreType tys) -- has spaces, but we never want parens - go (FunTy ty1 ty2) = RetExpr $ atomExpr (go ty1) <+> text "->" <+> ppCoreType ty2 - go (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar v <+> symbol '.' <+> ppCoreType ty + | GHC.isTupleTyCon tyCon = case map (ppCoreType isTySig) tys of + [] -> RetAtom $ tyText "()" + ds -> RetExpr $ tyText "(" <> (foldr1 (\d r -> d <> tyText "," <+> r) ds) <> tyText ")" + | otherwise = RetAtom $ ppName' isTySig (GHC.getName tyCon) <+> sep (map (ppCoreType isTySig) tys) -- has spaces, but we never want parens + go (FunTy ty1 ty2) = RetExpr $ atomExpr (go ty1) <+> text "->" <+> ppCoreType isTySig ty2 + go (ForAllTy v ty) = RetExpr $ specialSymbol ForallSymbol <+> ppVar' isTySig v <+> symbol '.' <+> ppCoreType isTySig ty + tyText = if isTySig then text else markColor TypeColor . text + ppCoreExpr0 :: PrettyH GHC.CoreExpr ppCoreExpr0 = caseT ppCoreExpr (const ppCoreAlt) (\ s b _ty alts -> - (keywordColor (text "case") <+> s <+> keywordColor (text "of") <+> ppIdBinder b) $$ + (keyword "case" <+> s <+> keyword "of" <+> optional (ppBinder b) id) $$ nest 2 (vcat alts)) <+ castT ppCoreExpr (\e co -> text "Cast" $$ nest 2 ((parens e) <+> ppSDoc co)) <+ tickT ppCoreExpr (\i e -> text "Tick" $$ nest 2 (ppSDoc i <+> parens e)) @@ -196,7 +218,7 @@ ppCoreBind :: PrettyH GHC.CoreBind ppCoreBind = nonRecT ppCoreExprR ppDefFun - <+ recT (const ppCoreDef) (\ bnds -> keywordColor (text "rec") <+> vcat bnds) + <+ recT (const ppCoreDef) (\ bnds -> keyword "rec" <+> vcat bnds) ppCoreAlt :: PrettyH GHC.CoreAlt ppCoreAlt = altT ppCoreExpr $ \ con ids e -> case con of @@ -205,7 +227,7 @@ GHC.DEFAULT -> symbol '_' <+> ppIds ids <+> e where ppIds ids | null ids = specialSymbol RightArrowSymbol - | otherwise = hsep (map ppIdBinder ids) <+> specialSymbol RightArrowSymbol + | otherwise = hsep (map (flip optional id . ppBinder) ids) <+> specialSymbol RightArrowSymbol -- GHC uses a tuple, which we print here. The CoreDef type is our doing. ppCoreDef :: PrettyH CoreDef @@ -216,12 +238,10 @@ RetLam vs e0 -> hang (pre <+> specialSymbol LambdaSymbol <+> hsep vs <+> specialSymbol RightArrowSymbol) 2 e0 _ -> hang pre 2 (normalExpr e) where - pre = case ppBinder i of - Nothing -> empty - Just p -> p <+> symbol '=' + pre = optional (ppBinder i) (<+> symbol '=') promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr) - <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram) + <+ promoteT (ppCoreProg :: PrettyH CoreProg) <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind) <+ promoteT (ppCoreDef :: PrettyH CoreDef) <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts) diff --git a/src/Language/HERMIT/PrettyPrinter/GHC.hs b/src/Language/HERMIT/PrettyPrinter/GHC.hs --- a/src/Language/HERMIT/PrettyPrinter/GHC.hs +++ b/src/Language/HERMIT/PrettyPrinter/GHC.hs @@ -7,6 +7,7 @@ import qualified GhcPlugins as GHC import Language.HERMIT.Kure +import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter import Text.PrettyPrint.MarkedHughesPJ as PP @@ -36,8 +37,8 @@ ppModGuts :: PrettyH GHC.ModGuts ppModGuts = arr (ppSDoc . GHC.mg_binds) - ppProgram :: PrettyH GHC.CoreProgram - ppProgram = arr ppSDoc + ppCoreProg :: PrettyH CoreProg + ppCoreProg = arr (ppSDoc . progToBinds) ppCoreExpr :: PrettyH GHC.CoreExpr ppCoreExpr = arr ppSDoc @@ -52,7 +53,7 @@ ppCoreDef = defT ppCoreExpr $ \ i e -> ppSDoc i <> text "=" <> e promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr) - <+ promoteT (ppProgram :: PrettyH GHC.CoreProgram) + <+ promoteT (ppCoreProg :: PrettyH CoreProg) <+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind) <+ promoteT (ppCoreDef :: PrettyH CoreDef) <+ promoteT (ppModGuts :: PrettyH GHC.ModGuts) diff --git a/src/Language/HERMIT/PrettyPrinter/JSON.hs b/src/Language/HERMIT/PrettyPrinter/JSON.hs --- a/src/Language/HERMIT/PrettyPrinter/JSON.hs +++ b/src/Language/HERMIT/PrettyPrinter/JSON.hs @@ -10,6 +10,7 @@ import qualified GhcPlugins as GHC import Language.HERMIT.Kure +import Language.HERMIT.Core import Language.HERMIT.PrettyPrinter corePrettyH :: PrettyOptions -> TranslateH Core Value @@ -27,9 +28,10 @@ ppModGuts :: TranslateH GHC.ModGuts Value ppModGuts = arr (ppSDoc . GHC.mg_module) - -- DocH is not a monoid, so we can't use listT here - ppProgram :: TranslateH GHC.CoreProgram Value -- CoreProgram = [CoreBind] - ppProgram = translate $ \ c -> fmap toJSON . mapM (apply ppCoreBind c) + -- DocH is not a monoid. + -- GHC uses a list, which we print here. The CoreProg type is our doing. + ppCoreProg :: TranslateH CoreProg Value + ppCoreProg = translate $ \ c -> fmap toJSON . mapM (apply ppCoreBind c) . progToBinds ppCoreExpr :: TranslateH GHC.CoreExpr Value ppCoreExpr = varT (\i -> object [mkCon "Var", "value" .= ppSDoc i]) @@ -62,7 +64,7 @@ ppCoreDef = defT ppCoreExpr $ \ i e -> object [mkCon "CoreDef", "var" .= ppSDoc i, "exp" .= e] promoteT ppCoreExpr - <+ promoteT ppProgram + <+ promoteT ppCoreProg <+ promoteT ppCoreBind <+ promoteT ppCoreDef <+ promoteT ppModGuts diff --git a/src/Language/HERMIT/Primitive/AlphaConversion.hs b/src/Language/HERMIT/Primitive/AlphaConversion.hs --- a/src/Language/HERMIT/Primitive/AlphaConversion.hs +++ b/src/Language/HERMIT/Primitive/AlphaConversion.hs @@ -1,24 +1,52 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts #-} -module Language.HERMIT.Primitive.AlphaConversion where +module Language.HERMIT.Primitive.AlphaConversion + ( -- * Alpha-Renaming and Shadowing + externals + -- ** Alpha-Renaming + , alpha + , alphaLam + , alphaCaseBinder + , alphaAltIds + , alphaAlt + , alphaCase + , alphaLetVars + , alphaLetRecIds + , alphaLetOne + , alphaLet + , alphaConsOne + , alphaCons + -- ** Shadow Detection and Unshadowing + , unshadow + , visibleVarsT + , freshNameGenT + , freshNameGenAvoiding + , replaceVarR + ) +where import GhcPlugins hiding (empty) +import Control.Applicative import Control.Arrow import Data.Char (isDigit) -import Data.List (intersect, (\\), nub) +import Data.List (nub) +import Data.Monoid -import Language.HERMIT.Context +import Language.HERMIT.Core import Language.HERMIT.Monad import Language.HERMIT.Kure import Language.HERMIT.External -import Language.HERMIT.Primitive.GHC(freeVarsT, substR) +import Language.HERMIT.Primitive.GHC hiding (externals) import Language.HERMIT.Primitive.Common import qualified Language.Haskell.TH as TH import Prelude hiding (exp) +----------------------------------------------------------------------- + +-- | Externals for alpha-renaming. externals :: [External] externals = map (.+ Deep) [ external "alpha" alpha @@ -39,26 +67,19 @@ [ "renames the bound variable in a Let expression with one binder to the given name."] , external "alpha-let" (promoteExprR alphaLet) [ "renames the bound variables in a Let expression."] - , external "alpha-top" (promoteProgramR . alphaConsOne . Just) + , external "alpha-top" (promoteProgR . alphaConsOne . Just) [ "renames the bound variable in a top-level binding with one binder to the given name."] - , external "alpha-top" (promoteProgramR alphaCons) + , external "alpha-top" (promoteProgR alphaCons) [ "renames the bound variables in a top-level binding."] - - , external "shadow-query" (promoteExprT shadowedNamesQuery) - [ "List variable names shadowed by bindings in this expression." ] .+ Query - , external "if-shadow" (promoteExprR ifShadowingR) - [ "succeeds ONLY-IF bindings in this expression shadow free variable name(s)." ] - , external "unshadow" unshadow - [ "Rename local variable with manifestly unique names (x, x0, x1, ...)"] - + [ "Rename local variables with manifestly unique names (x, x0, x1, ...)."] ] ----------------------------------------------------------------------- -- --- freshNameGen is a function used in conjunction with cloneIdH, which clones an existing Id. +-- freshNameGen is a function used in conjunction with cloneVarH, which clones an existing 'Var'. -- But, what name should the new Id have? --- cloneIdH generates a new Unique -- so we are positive that the new Id will be new, +-- cloneVarH generates a new Unique -- so we are positive that the new Var will be new, -- but freshNameGen tries to assign a Name that will be meaningful to the user, and -- not shadow other names in scope. -- So, we start with the name of the original Id, and add an integer suffix @@ -67,66 +88,71 @@ -- 1. Any free variable name in the active Expr; or -- 2. Any bound variables in context. -visibleIds :: TranslateH CoreExpr [Id] -visibleIds = do ctx <- contextT - frees <- freeVarsT - return $ frees ++ (listBindings ctx) +-- | List all visible identifiers (in the expression or the context). +visibleVarsT :: TranslateH CoreExpr [Var] +visibleVarsT = boundVarsT `mappend` freeVarsT -freshNameGen :: (Maybe TH.Name) -> [Id] -> (String -> String) -freshNameGen newName idsToAvoid = - case newName of - Just name -> const (show name) - Nothing -> inventNames idsToAvoid +-- | If a name is provided replace the string with that, +-- otherwise modify the string making sure to /not/ clash with any visible variables. +freshNameGenT :: Maybe TH.Name -> TranslateH CoreExpr (String -> String) +freshNameGenT mn = freshNameGenAvoiding mn <$> visibleVarsT -freshNameGenT :: (Maybe TH.Name) -> TranslateH CoreExpr (String -> String) -freshNameGenT newName = - case newName of - Just name -> return $ const (show name) - Nothing -> do idsToAvoid <- visibleIds - return $ freshNameGen Nothing idsToAvoid +-- | A generalisation of 'freshNameGen' that operates on any node, but only avoids name clashes with the results of the argument translation. +freshNameGenAvoiding :: Maybe TH.Name -> [Var] -> (String -> String) +freshNameGenAvoiding mn vs str = maybe (inventNames vs str) TH.nameBase mn -inventNames :: [Id] -> String -> String +-- | Invent a new String based on the old one, but avoiding clashing with the given list of identifiers. +inventNames :: [Var] -> String -> String inventNames curr old = head [ nm | nm <- old : [ base ++ show uq | uq <- [start ..] :: [Int] ] , nm `notElem` names ] where - names = map getOccString curr + names = nub (map getOccString curr) nums = reverse $ takeWhile isDigit (reverse old) baseLeng = length $ drop (length nums) old base = take baseLeng old start = case reads nums of - [(v,_)] -> (v + 1) - _ -> 0 + [(v,_)] -> v + 1 + _ -> 0 -shadowedNamesT :: TranslateH CoreExpr [String] -shadowedNamesT = do ctx <- contextT - frees <- freeVarsT - bindingIds <- extractT bindingVarsT - let shadows = intersect (map getOccString bindingIds) - (map getOccString (frees ++ (listBindings ctx))) - return shadows --- | Output a list of all variables that shadowed by bindings in the is expression. -shadowedNamesQuery :: TranslateH CoreExpr String -shadowedNamesQuery = shadowedNamesT >>^ (("Names shadowed by bindings in the current expression: " ++) . show) +-- | Remove all variables from the first list that shadow a variable in the second list. +shadowedBy :: [Var] -> [Var] -> [Var] +shadowedBy vs fvs = filter (\ v -> getOccString v `elem` map getOccString fvs) vs -ifShadowingR :: RewriteH CoreExpr -ifShadowingR = do shadows <- shadowedNamesT - case shadows of - [] -> fail "Bindings at this node do not shadow." - _ -> idR +-- | Lifted version of 'shadowedBy'. +-- Additionally, it fails if no shadows are found. +shadowedByT :: TranslateH a [Var] -> TranslateH a [Var] -> TranslateH a [Var] +shadowedByT t1 t2 = (shadowedBy <$> t1 <*> t2) >>> acceptR (not . null) "No shadowing detected." --- | Arguments are the original identifier and the replacement identifier, respectively. -renameIdR :: (Injection a Core, Generic a ~ Core) => Id -> Id -> RewriteH a -renameIdR v v' = extractR $ tryR $ substR v (Var v') +-- | Rename local variables with manifestly unique names (x, x0, x1, ...). +-- Does not rename top-level definitions (though this may change in the future). +unshadow :: RewriteH Core +unshadow = setFailMsg "No shadows to eliminate." $ + anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt) --- | Given an identifier to replace, and a replacement, produce an 'Id' @->@ 'Id' function that --- acts as in identity for all 'Id's except the one to replace, for which it returns the replacment. + where + unshadowExpr :: RewriteH CoreExpr + unshadowExpr = do vs <- shadowedByT (boundVarsT `mappend` freeVarsT) (letVarsT <+ fmap return (caseWildVarT <+ lamVarT)) + alphaLam Nothing <+ alphaLetRecIds vs <+ alphaLetNonRec Nothing <+ alphaCaseBinder Nothing + + unshadowAlt :: RewriteH CoreAlt + unshadowAlt = shadowedByT altVarsT (boundVarsT `mappend` altFreeVarsT) >>= alphaAltIds + +----------------------------------------------------------------------- + +-- | Replace all occurrences of a specified variable. +-- Arguments are the variable to replace and the replacement variable, respectively. +replaceVarR :: (Injection a Core, Generic a ~ Core) => Var -> Var -> RewriteH a +replaceVarR v v' = extractR $ tryR $ substR v (Var v') + +-- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that +-- acts as in identity for all 'Var's except the one to replace, for which it returns the replacment. -- Don't export this, it'll likely just cause confusion. -replaceId :: Id -> Id -> (Id -> Id) -replaceId v v' i = if v == i then v' else i +replaceVar :: Var -> Var -> (Var -> Var) +replaceVar v v' i = if v == i then v' else i ----------------------------------------------------------------------- @@ -134,8 +160,8 @@ alphaLam :: Maybe TH.Name -> RewriteH CoreExpr alphaLam mn = setFailMsg (wrongFormForAlpha "Lam v e") $ do (v, nameModifier) <- lamT (freshNameGenT mn) (,) - v' <- constT (cloneIdH nameModifier v) - lamT (renameIdR v v') (\ _ -> Lam v') + v' <- constT (cloneVarH nameModifier v) + lamT (replaceVarR v v') (\ _ -> Lam v') ----------------------------------------------------------------------- @@ -144,22 +170,24 @@ alphaCaseBinder mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $ do Case _ v _ _ <- idR nameModifier <- freshNameGenT mn - v' <- constT (cloneIdH nameModifier v) - caseT idR (\ _ -> renameIdR v v') (\ e _ t alts -> Case e v' t alts) + v' <- constT (cloneVarH nameModifier v) + caseT idR (\ _ -> replaceVarR v v') (\ e _ t alts -> Case e v' t alts) ----------------------------------------------------------------------- -- | Rename the specified identifier in a case alternative. Optionally takes a suggested new name. alphaAltId :: Maybe TH.Name -> Id -> RewriteH CoreAlt alphaAltId mn v = do nameModifier <- altT (freshNameGenT mn) (\ _ _ nameGen -> nameGen) - v' <- constT (cloneIdH nameModifier v) - altT (renameIdR v v') (\ con vs e -> (con, map (replaceId v v') vs, e)) + v' <- constT (cloneVarH nameModifier v) + altT (replaceVarR v v') (\ con vs e -> (con, map (replaceVar v v') vs, e)) +-- | Rename the specified identifiers in a case alternative. +alphaAltIds :: [Id] -> RewriteH CoreAlt +alphaAltIds = andR . map (alphaAltId Nothing) + -- | Rename all identifiers bound in a case alternative. alphaAlt :: RewriteH CoreAlt -alphaAlt = setFailMsg (wrongFormForAlpha "(con,vs,e)") $ - do (_, vs, _) <- idR - andR $ map (alphaAltId Nothing) vs +alphaAlt = altVarsT >>= alphaAltIds ----------------------------------------------------------------------- @@ -173,30 +201,36 @@ alphaLetNonRec :: Maybe TH.Name -> RewriteH CoreExpr alphaLetNonRec mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $ do (v, nameModifier) <- letNonRecT idR (freshNameGenT mn) (\ v _ nameMod -> (v, nameMod)) - v' <- constT (cloneIdH nameModifier v) - letNonRecT idR (renameIdR v v') (\ _ e1 e2 -> Let (NonRec v' e1) e2) + v' <- constT (cloneVarH nameModifier v) + letNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> Let (NonRec v' e1) e2) +-- | Alpha rename a non-recursive let binder if the variable appears in the argument list. Optionally takes a suggested new name. +alphaLetNonRecVars :: Maybe TH.Name -> [Var] -> RewriteH CoreExpr +alphaLetNonRecVars mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRec mn) + -- | Rename the specified identifier bound in a recursive let. Optionally takes a suggested new name. alphaLetRecId :: Maybe TH.Name -> Id -> RewriteH CoreExpr alphaLetRecId mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $ - do Let (Rec {}) _ <- idR - ctx <- contextT - -- Cannot use freshNameGen directly, because we want to include - -- free variables from every bound expression, in the name generation function - -- as a result we must replicate the essence of freshNameGen in the next few lines - frees <- letRecDefT (\ _ -> freeVarsT) freeVarsT (\ bindFrees exprFrees -> (concat (map snd bindFrees)) ++ exprFrees) - let nameGen = case mn of - Just name -> const (show name) - Nothing -> inventNames (frees ++ (listBindings ctx)) - v' <- constT (cloneIdH nameGen v) + do usedVars <- boundVarsT `mappend` + letVarsT `mappend` + letRecDefT (\ _ -> freeVarsT) freeVarsT (\ bndfvs vs -> concatMap snd bndfvs ++ vs) + v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v) + letRecDefT (\ _ -> replaceVarR v v') + (replaceVarR v v') + (\ bs e -> Let (Rec $ (map.first) (replaceVar v v') bs) e) - letRecDefT (\ _ -> renameIdR v v') (renameIdR v v') (\ bs e -> Let (Rec $ (map.first) (replaceId v v') bs) e) +-- | Rename the specified identifiers bound in a recursive let. +alphaLetRecIds :: [Id] -> RewriteH CoreExpr +alphaLetRecIds = andR . map (alphaLetRecId Nothing) +-- | Rename the specified variables bound in a let. +alphaLetVars :: [Var] -> RewriteH CoreExpr +alphaLetVars vs = alphaLetNonRecVars Nothing vs <+ alphaLetRecIds vs + -- | Rename all identifiers bound in a recursive let. alphaLetRec :: RewriteH CoreExpr alphaLetRec = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $ - do Let (Rec bs) _ <- idR - andR $ map (alphaLetRecId Nothing . fst) bs + letRecVarsT >>= alphaLetRecIds -- | Rename the identifier bound in a recursive let with a single recursively bound identifier. Optionally takes a suggested new name. alphaLetRecOne :: Maybe TH.Name -> RewriteH CoreExpr @@ -215,47 +249,45 @@ ----------------------------------------------------------------------- -- | Alpha rename a non-recursive top-level binder. Optionally takes a suggested new name. -alphaConsNonRec :: Maybe TH.Name -> RewriteH CoreProgram -alphaConsNonRec mn = setFailMsg (wrongFormForAlpha "NonRec v e : prog") $ - do NonRec v _ : _ <- idR +alphaConsNonRec :: Maybe TH.Name -> RewriteH CoreProg +alphaConsNonRec mn = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $ + do ProgCons (NonRec v _) _ <- idR nameModifier <- consNonRecT (freshNameGenT mn) idR (\ _ nameGen _ -> nameGen) - v' <- constT (cloneIdH nameModifier v) - consNonRecT idR (renameIdR v v') (\ _ e1 e2 -> NonRec v' e1 : e2) + v' <- constT (cloneVarH nameModifier v) + consNonRecT idR (replaceVarR v v') (\ _ e1 e2 -> ProgCons (NonRec v' e1) e2) -- | Rename the specified identifier bound in a recursive top-level binder. Optionally takes a suggested new name. -alphaConsRecId :: Maybe TH.Name -> Id -> RewriteH CoreProgram -alphaConsRecId mn v = setFailMsg (wrongFormForAlpha "Rec bs : prog") $ - do rbs@(Rec _) : _ <- idR - -- Cannot use freshNameGen directly, because we want to include - -- free variables from every bound expression, in the name generation function - -- as a result we must replicate the essence of freshNameGen in the next few lines - ctx <- contextT - frees <- consRecDefT (\ _ -> freeVarsT) idR (\ frees _ -> concat (map snd frees)) - let idsToAvoid = ((nub frees) \\ (bindings rbs)) ++ (listBindings ctx) - nameGen = case mn of - Just name -> const (show name) - Nothing -> inventNames idsToAvoid - v' <- constT (cloneIdH nameGen v) - consRecDefT (\ _ -> renameIdR v v') (renameIdR v v') (\ bs e -> Rec ((map.first) (replaceId v v') bs) : e) +alphaConsRecId :: Maybe TH.Name -> Id -> RewriteH CoreProg +alphaConsRecId mn v = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $ + do usedVars <- boundVarsT `mappend` + progConsT recVarsT (return ()) (\ vs () -> vs) `mappend` + consRecDefT (\ _ -> freeVarsT) idR (\ bndfvs _ -> concatMap snd bndfvs) + v' <- constT (cloneVarH (freshNameGenAvoiding mn usedVars) v) + consRecDefT (\ _ -> replaceVarR v v') + (replaceVarR v v') + (\ bs e -> ProgCons (Rec $ (map.first) (replaceVar v v') bs) e) +-- | Rename the specified identifiers bound in a program node containing a recursive binding group. +alphaConsRecIds :: [Id] -> RewriteH CoreProg +alphaConsRecIds = andR . map (alphaConsRecId Nothing) + -- | Rename all identifiers bound in a recursive top-level binder. -alphaConsRec :: RewriteH CoreProgram -alphaConsRec = setFailMsg (wrongFormForAlpha "Rec bs : prog") $ - do Rec bs : _ <- idR - andR $ map (alphaConsRecId Nothing . fst) bs +alphaConsRec :: RewriteH CoreProg +alphaConsRec = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $ + progConsT recVarsT mempty (\ vs () -> vs) >>= alphaConsRecIds -- | Rename the identifier bound in a recursive top-level binder with a single recursively bound identifier. Optionally takes a suggested new name. -alphaConsRecOne :: Maybe TH.Name -> RewriteH CoreProgram -alphaConsRecOne mn = setFailMsg (wrongFormForAlpha "Rec [(v,e)] : prog") $ - do Rec [(v, _)] : _ <- idR +alphaConsRecOne :: Maybe TH.Name -> RewriteH CoreProg +alphaConsRecOne mn = setFailMsg (wrongFormForAlpha "ProgCons (Rec [Def v e]) p") $ + do ProgCons (Rec [(v, _)]) _ <- idR alphaConsRecId mn v -- | Rename the identifier bound in a top-level binder with a single bound identifier. Optionally takes a suggested new name. -alphaConsOne :: Maybe TH.Name -> RewriteH CoreProgram +alphaConsOne :: Maybe TH.Name -> RewriteH CoreProg alphaConsOne mn = alphaConsNonRec mn <+ alphaConsRecOne mn -- | Rename all identifiers bound in a Let. -alphaCons :: RewriteH CoreProgram +alphaCons :: RewriteH CoreProg alphaCons = alphaConsRec <+ alphaConsNonRec Nothing ----------------------------------------------------------------------- @@ -264,13 +296,12 @@ alpha :: RewriteH Core alpha = setFailMsg "Cannot alpha-rename here." $ promoteExprR (alphaLam Nothing <+ alphaCaseBinder Nothing <+ alphaLet) - <+ promoteProgramR alphaCons - -unshadow :: RewriteH Core -unshadow = setFailMsg "No shadows to eliminate." $ - anytdR (promoteExprR (ifShadowingR >>> (alphaLam Nothing <+ alphaCase <+ alphaLet))) + <+ promoteProgR alphaCons + <+ promoteAltR alphaAlt ----------------------------------------------------------------------- wrongFormForAlpha :: String -> String -wrongFormForAlpha s = "Cannot alpha-rename: " ++ wrongExprForm s +wrongFormForAlpha s = "Cannot alpha-rename, " ++ wrongExprForm s + +----------------------------------------------------------------------- diff --git a/src/Language/HERMIT/Primitive/Common.hs b/src/Language/HERMIT/Primitive/Common.hs --- a/src/Language/HERMIT/Primitive/Common.hs +++ b/src/Language/HERMIT/Primitive/Common.hs @@ -1,94 +1,135 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, FlexibleContexts, TupleSections #-} - -- | Note: this module should NOT export externals. It is for common -- transformations needed by the other primitive modules. module Language.HERMIT.Primitive.Common - ( altFreeVarsT - , bindings - , bindingVarsT - , caseAltVarsT - , caseBinderVarT + ( -- * Utility Transformations + -- ** Collecting variables bound at a Node + progVarsT + , bindVarsT + , nonRecVarT + , recVarsT + , defVarT + , lamVarT , letVarsT + , letRecVarsT + , letNonRecVarT + , caseVarsT + , caseWildVarT + , caseAltVarsT + , altVarsT + -- ** Finding variables bound in the Context + , boundVarsT + , findBoundVarT + , findIdT + -- ** Error Message Generators , wrongExprForm - ) where + ) -import GhcPlugins +where -import Control.Arrow +import GhcPlugins import Data.List import Data.Monoid import Language.HERMIT.Kure - -import Language.HERMIT.Primitive.GHC +import Language.HERMIT.Core +import Language.HERMIT.Context +import Language.HERMIT.GHC +import qualified Language.Haskell.TH as TH -class BindEnv a where - bindings :: a -> [Id] +------------------------------------------------------------------------------ --- | All the identifiers bound in this binding group. -instance BindEnv CoreBind where - bindings (NonRec b _) = [b] - bindings (Rec bs) = map fst bs +-- | List all identifiers bound at the top-level in a program. +progVarsT :: TranslateH CoreProg [Id] +progVarsT = progNilT [] <+ progConsT bindVarsT progVarsT (++) -instance BindEnv CoreAlt where - bindings (_,vs,_) = vs +-- | List all identifiers bound in a binding group. +bindVarsT :: TranslateH CoreBind [Var] +bindVarsT = fmap return nonRecVarT <+ recVarsT -instance BindEnv CoreExpr where - bindings (Lam b _) = [b] - bindings (Let bs _) = bindings bs - bindings (Case _ sc _ alts) = sc : (nub (concat (map bindings alts))) - bindings _ = [] +-- | Return the variable bound by a non-recursive let expression. +nonRecVarT :: TranslateH CoreBind Var +nonRecVarT = nonRecT mempty (\ v () -> v) -instance BindEnv CoreProgram where - bindings prog = nub (concat (map bindings prog)) +-- | List all identifiers bound in a recursive binding group. +recVarsT :: TranslateH CoreBind [Id] +recVarsT = recT (\ _ -> defVarT) id -instance BindEnv CoreDef where - bindings (Def b _) = [b] +-- | Return the identifier bound by a recursive definition. +defVarT :: TranslateH CoreDef Id +defVarT = defT mempty (\ v () -> v) -bindingVarsT :: TranslateH Core [Var] -bindingVarsT = translate $ \ c core -> case core of - ModGutsCore _ -> fail "Cannot get binding vars at topmost level" - ProgramCore x -> apply (promoteT ((arr bindings) :: TranslateH CoreProgram [Var])) c x - BindCore x -> apply (promoteT ((arr bindings) :: TranslateH CoreBind [Var])) c x - DefCore x -> apply (promoteT ((arr bindings) :: TranslateH CoreDef [Var])) c x - ExprCore x -> apply (promoteT ((arr bindings) :: TranslateH CoreExpr [Var])) c x - AltCore x -> apply (promoteT ((arr bindings) :: TranslateH CoreAlt [Var])) c x +-- | Return the variable bound by a lambda expression. +lamVarT :: TranslateH CoreExpr Var +lamVarT = lamT mempty (\ v () -> v) --- TODO. Isn't there a better way to handle this ? --- Although the work of this Translate is handled by bindingVarsT --- This implementation fails for any expression that is not a Let. --- This specific argument matching is required where it is used in Local/Let.hs and Local/Case.hs +-- | List the variables bound by a let expression. letVarsT :: TranslateH CoreExpr [Var] -letVarsT = setFailMsg "Not a Let expression." $ - do Let bs _ <- idR - return (bindings bs) +letVarsT = letT bindVarsT mempty (\ vs () -> vs) --- | List of the list of Ids bound by each case alternative -caseAltVarsT :: TranslateH CoreExpr [[Id]] -caseAltVarsT = caseT mempty (const (extractT bindingVarsT)) $ \ () _ _ vs -> vs +-- | List the variables bound by a recursive let expression. +letRecVarsT :: TranslateH CoreExpr [Var] +letRecVarsT = letT recVarsT mempty (\ vs () -> vs) --- | List of the list of Ids bound by each case alternative, including the Case binder in each list -caseAltVarsWithBinderT :: TranslateH CoreExpr [[Id]] -caseAltVarsWithBinderT = caseT mempty (const (extractT bindingVarsT)) $ \ () v _ vs -> map (v:) vs +-- | Return the variable bound by a non-recursive let expression. +letNonRecVarT :: TranslateH CoreExpr Var +letNonRecVarT = letT nonRecVarT mempty (\ v () -> v) --- | list containing the single Id of the case binder -caseBinderVarT :: TranslateH CoreExpr [Id] -caseBinderVarT = setFailMsg "Not a Case expression." $ - do Case _ b _ _ <- idR - return [b] +-- | List all variables bound by a case expression (in the alternatives and the wildcard binder). +caseVarsT :: TranslateH CoreExpr [Var] +caseVarsT = caseT mempty (\ _ -> altVarsT) (\ () v _ vss -> v : nub (concat vss)) --- | Free variables for a CoreAlt, returns a function, which accepts --- the coreBndr name, before giving a result. --- This is so we can use this with congruence combinators: --- --- caseT id (const altFreeVarsT) $ \ _ bndr _ fs -> [ f bndr | f <- fs ] -altFreeVarsT :: TranslateH CoreAlt (Id -> [Var]) -altFreeVarsT = altT freeVarsT $ \ _con ids frees coreBndr -> nub frees \\ nub (coreBndr : ids) +-- | Return the case wildcard binder. +caseWildVarT :: TranslateH CoreExpr Var +caseWildVarT = caseT mempty (\ _ -> return ()) (\ () v _ _ -> v) +-- | List the variables bound by all alternatives in a case expression. +caseAltVarsT :: TranslateH CoreExpr [[Var]] +caseAltVarsT = caseT mempty (\ _ -> altVarsT) (\ () _ _ vss -> vss) + +-- | List the variables bound by a case alternative. +altVarsT :: TranslateH CoreAlt [Var] +altVarsT = altT mempty (\ _ vs () -> vs) + ------------------------------------------------------------------------------ +-- Need a better error type so that we can factor out the repetition. + +-- | Lifted version of 'boundVars'. +boundVarsT :: TranslateH a [Var] +boundVarsT = contextonlyT (return . boundVars) + +-- | Find the unique variable bound in the context that matches the given name, failing if it is not unique. +findBoundVarT :: TH.Name -> TranslateH a Var +findBoundVarT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $ + do c <- contextT + case findBoundVars nm c of + [] -> fail "no matching variables in scope." + [v] -> return v + _ : _ : _ -> fail "multiple matching variables in scope." + +-- | Lookup the name in the 'HermitC' first, then, failing that, in GHC's global reader environment. +findIdT :: TH.Name -> TranslateH a Id +findIdT nm = prefixFailMsg ("Cannot resolve name " ++ TH.nameBase nm ++ ", ") $ + do c <- contextT + case findBoundVars nm c of + [] -> findIdMG nm + [v] -> return v + _ : _ : _ -> fail "multiple matching variables in scope." + +findIdMG :: TH.Name -> TranslateH a Id +findIdMG nm = contextonlyT $ \ c -> + case filter isValName $ findNameFromTH (mg_rdr_env $ hermitModGuts c) nm of + [] -> fail $ "variable not in scope." + [n] -> lookupId n + ns -> do dynFlags <- getDynFlags + fail $ "multiple matches found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns) + +------------------------------------------------------------------------------ + +-- | Constructs a common error message. +-- Argument 'String' should be the desired form of the expression. wrongExprForm :: String -> String wrongExprForm form = "Expression does not have the form: " ++ form diff --git a/src/Language/HERMIT/Primitive/Debug.hs b/src/Language/HERMIT/Primitive/Debug.hs --- a/src/Language/HERMIT/Primitive/Debug.hs +++ b/src/Language/HERMIT/Primitive/Debug.hs @@ -8,6 +8,7 @@ ) where +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.Monad diff --git a/src/Language/HERMIT/Primitive/FixPoint.hs b/src/Language/HERMIT/Primitive/FixPoint.hs new file mode 100644 --- /dev/null +++ b/src/Language/HERMIT/Primitive/FixPoint.hs @@ -0,0 +1,214 @@ +module Language.HERMIT.Primitive.FixPoint where + +import GhcPlugins as GHC hiding (varName) + +import Control.Arrow + +import Language.HERMIT.Core +import Language.HERMIT.Monad +import Language.HERMIT.Kure +import Language.HERMIT.External +import Language.HERMIT.GHC +import Language.HERMIT.Primitive.GHC +import Language.HERMIT.Primitive.Common +import Language.HERMIT.Primitive.Local +import Language.HERMIT.Primitive.AlphaConversion +import Language.HERMIT.Primitive.New -- TODO: Sort out heirarchy + +import qualified Language.Haskell.TH as TH + + +externals :: [External] +externals = map ((.+ Experiment) . (.+ TODO)) + [ external "fix-intro" (promoteDefR fixIntro :: RewriteH Core) + [ "rewrite a recursive binding into a non-recursive binding using fix" ] + , external "fix-spec" (promoteExprR fixSpecialization :: RewriteH Core) + [ "specialize a fix with a given argument"] .+ Shallow + , external "ww-fac-test" ((\ wrap unwrap -> promoteExprR $ workerWrapperFacTest wrap unwrap) :: TH.Name -> TH.Name -> RewriteH Core) + [ "Under construction " + ] .+ Introduce .+ Context .+ Experiment .+ PreCondition + , external "ww-split-test" ((\ wrap unwrap -> promoteDefR $ workerWrapperSplitTest wrap unwrap) :: TH.Name -> TH.Name -> RewriteH Core) + [ "Under construction " + ] .+ Introduce .+ Context .+ Experiment .+ PreCondition + ] + +fixLocation :: String +fixLocation = "Data.Function.fix" + +findFixId :: TranslateH a Id +findFixId = findIdT (TH.mkName fixLocation) + +guardIsFixId :: Id -> TranslateH a () +guardIsFixId v = do fixId <- findFixId + guardMsg (v == fixId) (var2String v ++ " does not match " ++ fixLocation) + + +-- | f = e ==> f = fix (\ f -> e) +fixIntro :: RewriteH CoreDef +fixIntro = prefixFailMsg "Fix introduction failed: " $ + do Def f e <- idR + fixId <- findFixId + constT $ do f' <- cloneVarH id f + let coreFix = App (App (Var fixId) (Type (idType f))) + emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars e)) + sub = extendSubst emptySub f (Var f') + return $ Def f (coreFix (Lam f' (substExpr (text "fixIntro") sub e))) + +-- ironically, this is an instance of worker/wrapper itself. + +fixSpecialization :: RewriteH CoreExpr +fixSpecialization = do + + -- fix (t::*) (f :: t -> t) (a :: t) :: t + App (App (App (Var fixId) (Type _)) _) _ <- idR -- TODO: couldn't that Type be a Var? Might be better to use my "isType" fucntion. + + guardIsFixId fixId -- guardMsg (fx == fixId) "fixSpecialization only works on fix" + + let rr :: RewriteH CoreExpr + rr = multiEtaExpand [TH.mkName "f",TH.mkName "a"] + + sub :: RewriteH Core + sub = pathR [0,1] (promoteR rr) + -- be careful this does not loop (it should not) + extractR sub >>> fixSpecialization' + + +fixSpecialization' :: RewriteH CoreExpr +fixSpecialization' = + do + -- In normal form now + App (App (App (Var fx) fixTyE) + (Lam _ (Lam v2 (App (App e _) _a2))) + ) + a <- idR + + t <- case typeExprToType fixTyE of + Nothing -> fail "first argument to fix is not a type, this shouldn't have happened." + Just ty -> return ty + + t' <- case typeExprToType a of + Just t2 -> return (applyTy t t2) + Nothing -> fail "Not a type variable." -- TODO: I think this entire functions needs revisiting and cleaning up. What's going on with all the dead-code (which I've commented out now). +-- Var a2 -> mkAppTy t (exprType t2) +-- mkAppTy t t' + + + -- TODO: t2' isn't used anywhere -- which means that a2 is never used ??? +-- let t2' = case a2 of +-- Type t2 -> applyTy t t2 +-- Var a2 -> mkAppTy t (exprType t2) +-- mkAppTy t t' + + + v3 <- constT $ newIdH "f" t' -- (funArgTy t') + v4 <- constT $ newTyVarH "a" (tyVarKind v2) + + -- f' :: \/ a -> T [a] -> (\/ b . T [b]) + let f' = Lam v4 (Cast (Var v3) + (mkUnsafeCo t' (applyTy t (mkTyVarTy v4)))) + let e' = Lam v3 (App (App e f') a) + + return $ App (App (Var fx) (Type t')) e' + + +-- introSpecialisedPolyFun :: TH.Name -> TH.Name -> RewriteH CoreExpr +-- introSpecialisedPolyFun funNm ty = do funId <- lookupMatchingVarT funNm +-- tyVar <- lookupMatchingVarT ty + + + +workerWrapperFacTest :: TH.Name -> TH.Name -> RewriteH CoreExpr +workerWrapperFacTest wrapNm unwrapNm = do wrapId <- findBoundVarT wrapNm + unwrapId <- findBoundVarT unwrapNm + monomorphicWorkerWrapperFac (Var wrapId) (Var unwrapId) + +workerWrapperSplitTest :: TH.Name -> TH.Name -> RewriteH CoreDef +workerWrapperSplitTest wrapNm unwrapNm = do wrapId <- findBoundVarT wrapNm + unwrapId <- findBoundVarT unwrapNm + monomorphicWorkerWrapperSplit (Var wrapId) (Var unwrapId) + + +-- monomorphicWorkerWrapperFac :: Id -> Id -> RewriteH CoreExpr +-- monomorphicWorkerWrapperFac wrapId unwrapId = -- let wrapTy = idType wrapId +-- -- unwrapTy = idType unwrapId +-- -- (wrapForallTyVars, wrapMainTy) = splitForAllTys wrapTy +-- -- (unwrapForallTyVars, unwrapMainTy) = splitForAllTys unwrapTy + +-- -- in -- In progress: above are not used yet. +-- workerWrapperFac (Var wrapId) (Var unwrapId) +-- -- workerWrapperFac (mkTyApps (Var wrapId) wrapForallTys) +-- -- (mkTyApps (Var unwrapId) unwrapForallTys) + +-- workerWrapperFac (Var wrapId) (Var unwrapId) +-- splitForAllTys :: Type -> ([TyVar], Type) + +-- monomorphicWorkerWrapperSplit :: Id -> Id -> RewriteH CoreDef +-- monomorphicWorkerWrapperSplit wrapId unwrapId = workerWrapperSplit (Var wrapId) (Var unwrapId) + +-- substTyWith :: [TyVar] -> [Type] -> Type -> Type +-- mkTyApps :: Expr b -> [Type] -> Expr b + +-- I assume there are GHC functions to do this, but I can't find them. +-- in progress +-- unifyTyVars :: [TyVar] -- | forall quantified type variables +-- -> Type -- | type containing forall quantified type variables +-- -> Type -- | type to unify with +-- -> Maybe [Type] -- | types that the variables have been unified with +-- unifyTyVars vs tyGen tySpec = let unifyTyVarsAux tyGen tySpec vs +-- in undefined +-- unifyTyVarsAux :: Type -> Type -> [(TyVar,[Type])] -> Maybe [(TyVar,[Type])] +-- unifyTyVarsAux (TyVarTy v) t = match v t +-- unifyTyVarsAux (AppTy s1 s2) (AppTy t1 t2) = match s1 t1 . match s2 t2 + + +-- f :: a -> a +-- wrap :: forall x,y..z. b -> a +-- unwrap :: forall p,q..r. a -> b +-- fix tyA f ==> wrap (fix tyB (\ x -> unwrap (f (wrap (Var x))))) +-- Assumes the arguments are monomorphic functions (all type variables have alread been applied) +monomorphicWorkerWrapperFac :: CoreExpr -> CoreExpr -> RewriteH CoreExpr +monomorphicWorkerWrapperFac wrapE unwrapE = + prefixFailMsg "Worker/wrapper Factorisation failed: " $ + withPatFailMsg (wrongExprForm "fix type fun") $ + do App (App (Var fixId) fixTyE) f <- idR -- fix :: forall a. (a -> a) -> a + guardIsFixId fixId + case typeExprToType fixTyE of + Nothing -> fail "first argument to fix is not a type, this shouldn't have happened." + Just tyA -> case splitFunTy_maybe (exprType wrapE) of + Nothing -> fail "type of wrapper is not a function." + Just (tyB,wrapTyA) -> case splitFunTy_maybe (exprType unwrapE) of + Nothing -> fail "type of unwrapper is not a function." + Just (unwrapTyA,unwrapTyB) -> do guardMsg (eqType wrapTyA unwrapTyA) ("argument type of unwrapper does not match result type of wrapper.") + guardMsg (eqType unwrapTyB tyB) ("argument type of wrapper does not match result type of unwrapper.") + guardMsg (eqType wrapTyA tyA) ("wrapper/unwrapper types do not match expression type.") + x <- constT (newIdH "x" tyB) + return $ App wrapE + (App (App (Var fixId) (Type tyB)) + (Lam x (App unwrapE + (App f + (App wrapE + (Var x) + ) + ) + ) + ) + ) + + +monomorphicWorkerWrapperSplit :: CoreExpr -> CoreExpr -> RewriteH CoreDef +monomorphicWorkerWrapperSplit wrap unwrap = + let f = TH.mkName "f" + w = TH.mkName "w" + work = TH.mkName "work" + fx = TH.mkName "fix" + in + fixIntro >>> defR ( appAllR idR (letIntro f) + >>> letFloatArg + >>> letAllR idR ( monomorphicWorkerWrapperFac wrap unwrap + >>> appAllR idR (letIntro w) + >>> letFloatArg + >>> letNonRecAllR (unfold fx >>> alphaLetOne (Just work) >>> extractR simplifyR) idR + >>> letSubstR + >>> letFloatArg + ) + ) diff --git a/src/Language/HERMIT/Primitive/Fold.hs b/src/Language/HERMIT/Primitive/Fold.hs --- a/src/Language/HERMIT/Primitive/Fold.hs +++ b/src/Language/HERMIT/Primitive/Fold.hs @@ -1,9 +1,12 @@ module Language.HERMIT.Primitive.Fold - ( externals + ( -- * Fold/Unfold Transformation + externals , foldR , stashFoldR - ) where + ) +where + import GhcPlugins hiding (empty) import Control.Applicative @@ -12,10 +15,11 @@ import Data.List (intercalate) import qualified Data.Map as Map -import Language.HERMIT.Monad +import Language.HERMIT.Core import Language.HERMIT.Context -import Language.HERMIT.External +import Language.HERMIT.Monad import Language.HERMIT.Kure +import Language.HERMIT.External import Language.HERMIT.GHC import Language.HERMIT.Primitive.GHC hiding (externals) @@ -60,7 +64,7 @@ foldR :: TH.Name -> RewriteH CoreExpr foldR nm = prefixFailMsg "Fold failed: " $ translate $ \ c e -> do - i <- case filter (cmpTHName2Id nm) $ Map.keys (hermitBindings c) of + i <- case filter (cmpTHName2Var nm) $ Map.keys (hermitBindings c) of [] -> fail "cannot find name." [i] -> return i is -> fail $ "multiple names match: " ++ intercalate ", " (map var2String is) diff --git a/src/Language/HERMIT/Primitive/GHC.hs b/src/Language/HERMIT/Primitive/GHC.hs --- a/src/Language/HERMIT/Primitive/GHC.hs +++ b/src/Language/HERMIT/Primitive/GHC.hs @@ -1,128 +1,146 @@ -{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts, TupleSections #-} -module Language.HERMIT.Primitive.GHC where +module Language.HERMIT.Primitive.GHC + ( -- * GHC-based Transformations + -- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions. + externals + -- ** Free Variables + , coreExprFreeIds + , coreExprFreeVars + , freeIdsT + , freeVarsT + , altFreeVarsT + , altFreeVarsExclWildT + -- ** Substitution + , substR + , letSubstR + , safeLetSubstR + , safeLetSubstPlusR + -- ** Utilities + , inScope + , exprEqual + , showVars + , rules + ) +where -import GhcPlugins hiding (empty) +import GhcPlugins import qualified OccurAnal + import Control.Arrow import Control.Monad -import qualified Data.Map as Map -import Data.List (nub, mapAccumL) - --- import Language.HERMIT.Primitive.Debug -import Language.HERMIT.Primitive.Navigation +import Data.List (intercalate,mapAccumL,(\\)) -import Language.HERMIT.CoreExtra -import Language.HERMIT.Kure +import Language.HERMIT.Core +import Language.HERMIT.Context import Language.HERMIT.Monad +import Language.HERMIT.Kure import Language.HERMIT.External -import Language.HERMIT.Context -import qualified Language.HERMIT.GHC as GHC +import Language.HERMIT.GHC -import qualified Language.Haskell.TH as TH --- import Debug.Trace +import Language.HERMIT.Primitive.Navigation hiding (externals) -import Prelude hiding (exp) +import qualified Language.Haskell.TH as TH ------------------------------------------------------------------------ +-- | Externals that reflect GHC functions, or are derived from GHC functions. externals :: [External] externals = - [ external "let-subst" (promoteExprR letSubstR :: RewriteH Core) - [ "Let substitution [via GHC]" - , "let x = E1 in E2 ==> E2[E1/x], fails otherwise" - , "only matches non-recursive lets" ] .+ Deep + [ external "info" (info :: TranslateH Core String) + [ "display information about the current node." ] + , external "let-subst" (promoteExprR letSubstR :: RewriteH Core) + [ "Let substitution" + , "(let x = e1 in e2) ==> (e2[e1/x])" + , "x must not be free in e1." ] .+ Deep , external "safe-let-subst" (promoteExprR safeLetSubstR :: RewriteH Core) - [ "Safe let substitution [via GHC]" - , "let x = E1 in E2, safe to inline without duplicating work ==> E2[E1/x]," - , "fails otherwise" - , "only matches non-recursive lets" ] .+ Deep .+ Eval .+ Bash + [ "Safe let substitution" + , "let x = e1 in e2, safe to inline without duplicating work ==> e2[e1/x]," + , "x must not be free in e1." ] .+ Deep .+ Eval .+ Bash , external "safe-let-subst-plus" (promoteExprR safeLetSubstPlusR :: RewriteH Core) - [ "Safe let substitution [via GHC]" - , "let { x = E1, ... } in E2, " - , " where safe to inline without duplicating work ==> E2[E1/x,...]," - , "fails otherwise" + [ "Safe let substitution" + , "let { x = e1, ... } in e2, " + , " where safe to inline without duplicating work ==> e2[e1/x,...]," , "only matches non-recursive lets" ] .+ Deep .+ Eval , external "free-ids" (promoteExprT freeIdsQuery :: TranslateH Core String) - [ "List the free identifiers in this expression [via GHC]" ] .+ Query .+ Deep - , external "deshadow-binds" (promoteProgramR deShadowBindsR :: RewriteH Core) - [ "Deshadow a program " ] .+ Deep + [ "List the free identifiers in this expression." ] .+ Query .+ Deep + , external "deshadow-prog" (promoteProgR deShadowProgR :: RewriteH Core) + [ "Deshadow a program." ] .+ Deep , external "apply-rule" (promoteExprR . rules :: String -> RewriteH Core) [ "apply a named GHC rule" ] .+ Shallow , external "apply-rule" (rules_help :: TranslateH Core String) [ "list rules that can be used" ] .+ Query , external "compare-values" compareValues - ["compare's the rhs of two values"] .+ Query .+ Predicate + ["compare the rhs of two values."] .+ Query .+ Predicate , external "add-rule" (\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name)) ["add-rule \"rule-name\" -- adds a new rule that freezes the right hand side of the "] .+ Introduce , external "cast-elim" (promoteExprR castElimination) ["cast-elim removes casts"] - .+ Shallow .+ TODO + .+ Shallow .+ Experiment .+ TODO , external "add-rule" (\ rule_name id_name -> promoteModGutsR (addCoreBindAsRule rule_name id_name)) ["add-rule \"rule-name\" -- adds a new rule that freezes the right hand side of the "] - , external "flatten-module" (promoteModGutsR flattenModule :: RewriteH Core) - ["Flatten all the top-level binding groups into a single recursive binding group.", - "This can be useful if you intend to appply GHC RULES."] - , external "occur-analysis" (promoteExprR occurAnalyseExprR :: RewriteH Core) ["Performs dependency anlaysis on a CoreExpr.", "This can be useful to simplify a recursive let to a non-recursive let."] .+ Deep ] ------------------------------------------------------------------------ -substR :: Id -> CoreExpr -> RewriteH Core -substR b e = setFailMsg "Can only perform substitution on Expr or CoreProgram forms." $ - promoteExprR (substExprR b e) <+ promoteProgramR (substTopBindR b e) -substExprR :: Id -> CoreExpr -> RewriteH CoreExpr -substExprR b e = contextfreeT $ \ exp -> +-- | Substitute all occurrences of a variable with an expression, in either a program or an expression. +substR :: Var -> CoreExpr -> RewriteH Core +substR v e = setFailMsg "Can only perform substitution on expressions or programs." $ + promoteExprR (substExprR v e) <+ promoteProgR (substTopBindR v e) + +-- | Substitute all occurrences of a variable with an expression, in an expression. +substExprR :: Var -> CoreExpr -> RewriteH CoreExpr +substExprR v e = contextfreeT $ \ expr -> -- The InScopeSet needs to include any free variables appearing in the -- expression to be substituted. Constructing a NonRec Let expression -- to pass on to exprFeeVars takes care of this, but ... -- TODO Is there a better way to do this ??? - let emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars (Let (NonRec b e) exp))) - sub = if (isTyVar b) - then case e of - (Type bty) -> Just $ extendTvSubst emptySub b bty - (Var x) -> Just $ extendTvSubst emptySub b (mkTyVarTy x) - _ -> Nothing - else Just $ extendSubst emptySub b e - in - case sub of - Just sub' -> return $ substExpr (text "substR") sub' exp - Nothing -> fail "substExprR: Id argument is a TyVar, but the expression is not a Type." + let emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars (Let (NonRec v e) expr))) + in do + sub <- if isTyVar v + then case e of + Type vty -> return $ extendTvSubst emptySub v vty + Var x -> return $ extendTvSubst emptySub v (mkTyVarTy x) + _ -> fail "substExprR: Var argument is a TyVar, but the expression is not a Type." + else return $ extendSubst emptySub v e + return $ substExpr (text "substR") sub expr +-- | Substitute all occurrences of a variable with an expression, in a program. +substTopBindR :: Var -> CoreExpr -> RewriteH CoreProg +substTopBindR v e = contextfreeT $ \ p -> + -- TODO. Do we need to initialize the emptySubst with bindFreeVars? + let emptySub = emptySubst -- mkEmptySubst (mkInScopeSet (exprFreeVars exp)) + in do + sub <- if isTyVar v + then case e of + Type vty -> return $ extendTvSubst emptySub v vty + Var x -> return $ extendTvSubst emptySub v (mkTyVarTy x) + _ -> fail "substTopBindR: Var argument is a TyVar, but the expression is not a Type." + else return $ extendSubst emptySub v e + return $ bindsToProg $ snd (mapAccumL substBind sub (progToBinds p)) -substTopBindR :: Id -> CoreExpr -> RewriteH CoreProgram -substTopBindR b e = contextfreeT $ \ binds -> - -- TODO. Do we ned to initialize the emptySubst with bindFreeVars ? - let emptySub = emptySubst -- mkEmptySubst (mkInScopeSet (exprFreeVars exp)) - sub = if (isTyVar b) - then case e of - (Type bty) -> Just $ extendTvSubst emptySub b bty - (Var x) -> Just $ extendTvSubst emptySub b (mkTyVarTy x) - _ -> Nothing - else Just $ extendSubst emptySub b e - in - case sub of - Just sub' -> return $ snd (mapAccumL substBind sub' binds) - Nothing -> fail "substTopBindR: Id argument is a TyVar, but the expression is not a Type." +-- | (let x = e1 in e2) ==> (e2[e1/x]), +-- x must not be free in e1. letSubstR :: RewriteH CoreExpr letSubstR = prefixFailMsg "Let substition failed: " $ - rewrite $ \ ctx exp -> case occurAnalyseExpr exp of - Let (NonRec b be) e -> apply (substExprR b be) ctx e + rewrite $ \ c expr -> case occurAnalyseExpr expr of + Let (NonRec b be) e -> apply (substExprR b be) c e _ -> fail "expression is not a non-recursive Let." --- remove N lets, please -letSubstNR :: Int -> RewriteH Core -letSubstNR 0 = idR -letSubstNR n = childR 1 (letSubstNR (n - 1)) >>> promoteExprR letSubstR --- This is quite expensive (O(n) for the size of the sub-tree) +-- Neil: Commented this out as it's not (currently) used. +-- Perform let-substitution the specified number of times. +-- letSubstNR :: Int -> RewriteH Core +-- letSubstNR 0 = idR +-- letSubstNR n = childR 1 (letSubstNR (n - 1)) >>> promoteExprR letSubstR + +-- | This is quite expensive (O(n) for the size of the sub-tree). safeLetSubstR :: RewriteH CoreExpr safeLetSubstR = prefixFailMsg "Safe let-substition failed: " $ - translate $ \ env exp -> + translate $ \ env expr -> let -- Lit? safeBind (Var {}) = True safeBind (Lam {}) = True @@ -137,13 +155,13 @@ safeSubst IAmDead = True -- DCE safeSubst (OneOcc inLam oneBr _) = not inLam && oneBr -- do not inline inside a lambda or if in multiple case branches safeSubst _ = False -- strange case, like a loop breaker - in case occurAnalyseExpr exp of + in case occurAnalyseExpr expr of -- By (our) definition, types are a trivial bind Let (NonRec b _) _ - | isTyVar b -> apply letSubstR env exp + | isTyVar b -> apply letSubstR env expr Let (NonRec b be) _ | isId b && (safeBind be || safeSubst (occInfo (idInfo b))) - -> apply letSubstR env exp + -> apply letSubstR env expr | otherwise -> fail "safety critera not met." _ -> fail "expression is not a non-recursive Let." @@ -154,35 +172,98 @@ ------------------------------------------------------------------------ +info :: TranslateH Core String +info = translate $ \ c core -> do + dynFlags <- getDynFlags + let pa = "Path: " ++ show (contextPath c) + node = "Node: " ++ coreNode core + con = "Constructor: " ++ coreConstructor core + bds = "Bindings in Scope: " ++ show (map unqualifiedVarName $ boundVars c) + expExtra = case core of + ExprCore e -> ["Type or Kind: " ++ showExprTypeOrKind dynFlags e] ++ + ["Free Variables: " ++ showVars (coreExprFreeVars e)] + -- ++ + -- case e of + -- Var v -> ["Identifier Info: " ++ showIdInfo dynFlags v] -- TODO: what if this is a TyVar? + -- _ -> [] + _ -> [] + + return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra) + +showExprTypeOrKind :: DynFlags -> CoreExpr -> String +showExprTypeOrKind dynFlags = showPpr dynFlags . exprTypeOrKind + +-- showIdInfo :: DynFlags -> Id -> String +-- showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo v + +coreNode :: Core -> String +coreNode (ModGutsCore _) = "Module" +coreNode (ProgCore _) = "Program" +coreNode (BindCore _) = "Binding Group" +coreNode (DefCore _) = "Recursive Definition" +coreNode (ExprCore _) = "Expression" +coreNode (AltCore _) = "Case Alternative" + +coreConstructor :: Core -> String +coreConstructor (ModGutsCore _) = "ModGuts" +coreConstructor (ProgCore prog) = case prog of + ProgNil -> "ProgNil" + ProgCons _ _ -> "ProgCons" +coreConstructor (BindCore bnd) = case bnd of + Rec _ -> "Rec" + NonRec _ _ -> "NonRec" +coreConstructor (DefCore _) = "Def" +coreConstructor (AltCore _) = "(,,)" +coreConstructor (ExprCore expr) = case expr of + Var _ -> "Var" + Type _ -> "Type" + Lit _ -> "Lit" + App _ _ -> "App" + Lam _ _ -> "Lam" + Let _ _ -> "Let" + Case _ _ _ _ -> "Case" + Cast _ _ -> "Cast" + Tick _ _ -> "Tick" + Coercion _ -> "Coercion" + +------------------------------------------------------------------------ + -- | Output a list of all free variables in an expression. freeIdsQuery :: TranslateH CoreExpr String -freeIdsQuery = do - dynFlags <- constT getDynFlags - frees <- freeIdsT - return $ "Free identifiers are: " ++ showVars dynFlags frees - --- | Show a human-readable version of a 'Var'. -showVar :: DynFlags -> Var -> String -showVar dynFlags = show . showPpr dynFlags +freeIdsQuery = do frees <- freeIdsT + return $ "Free identifiers are: " ++ showVars frees -- | Show a human-readable version of a list of 'Var's. -showVars :: DynFlags -> [Var] -> String -showVars dynFlags = show . map (showPpr dynFlags) -- map GHC.var2String +showVars :: [Var] -> String +showVars = show . map var2String +-- | Lifted version of 'coreExprFreeIds'. freeIdsT :: TranslateH CoreExpr [Id] freeIdsT = arr coreExprFreeIds +-- | Lifted version of 'coreExprFreeVars'. freeVarsT :: TranslateH CoreExpr [Var] freeVarsT = arr coreExprFreeVars --- note: coreExprFreeVars get *all* free variables, including types +-- | List all free variables (including types) in the expression. coreExprFreeVars :: CoreExpr -> [Var] coreExprFreeVars = uniqSetToList . exprFreeVars --- note: coreExprFreeIds is only value-level free variables +-- | List all free identifiers (value-level free variables) in the expression. coreExprFreeIds :: CoreExpr -> [Id] coreExprFreeIds = uniqSetToList . exprFreeIds +-- | The free variables in a case alternative, which excludes any identifiers bound in the alternative. +altFreeVarsT :: TranslateH CoreAlt [Var] +altFreeVarsT = altT freeVarsT (\ _ vs fvs -> fvs \\ vs) + +-- | A variant of 'altFreeVarsT' that returns a function that accepts the case wild-card binder before giving a result. +-- This is so we can use this with congruence combinators, for example: +-- +-- caseT id (const altFreeVarsT) $ \ _ wild _ fvs -> [ f wild | f <- fvs ] +altFreeVarsExclWildT :: TranslateH CoreAlt (Id -> [Var]) +altFreeVarsExclWildT = altT freeVarsT (\ _ vs fvs wild -> fvs \\ (wild : vs)) + ------------------------------------------------------------------------ -- | [from GHC documentation] De-shadowing the program is sometimes a useful pre-pass. @@ -191,8 +272,8 @@ -- -- (Actually, within a single /type/ there might still be shadowing, because -- 'substTy' is a no-op for the empty substitution, but that's probably OK.) -deShadowBindsR :: RewriteH CoreProgram -deShadowBindsR = arr deShadowBinds +deShadowProgR :: RewriteH CoreProg +deShadowProgR = arr (bindsToProg . deShadowBinds . progToBinds) ------------------------------------------------------------------------ {- @@ -203,11 +284,12 @@ -> [CoreRule] -> Maybe (CoreRule, CoreExpr) -} -rulesToEnv :: [CoreRule] -> Map.Map String (RewriteH CoreExpr) -rulesToEnv rs = Map.fromList - [ ( unpackFS (ruleName r), rulesToRewriteH [r] ) - | r <- rs - ] +-- Neil: Commented this out as its not (currently) used. +-- rulesToEnv :: [CoreRule] -> Map.Map String (RewriteH CoreExpr) +-- rulesToEnv rs = Map.fromList +-- [ ( unpackFS (ruleName r), rulesToRewriteH [r] ) +-- | r <- rs +-- ] rulesToRewriteH :: [CoreRule] -> RewriteH CoreExpr rulesToRewriteH rs = translate $ \ c e -> do @@ -223,21 +305,21 @@ -- trace (showSDoc (ppr fn GhcPlugins.<+> ppr args $$ ppr rs)) $ case lookupRule (const True) (const NoUnfolding) in_scope fn args rs of Nothing -> fail "rule not matched" - Just (rule, exp) -> do - let e' = mkApps exp (drop (ruleArity rule) args) + Just (rule, expr) -> do + let e' = mkApps expr (drop (ruleArity rule) args) ifM (liftM (and . map (inScope c)) $ apply freeVarsT c e') (return e') (fail $ unlines ["Resulting expression after rule application contains variables that are not in scope." ,"This can probably be solved by running the flatten-module command at the top level."]) --- | See whether an identifier is in scope. -inScope :: Context -> Id -> Bool -inScope c i = maybe (case unfoldingInfo (idInfo i) of - CoreUnfolding {} -> True -- defined elsewhere - _ -> False) - (const True) -- defined in this module - (lookupHermitBinding i c) +-- | Determine whether an identifier is in scope. +inScope :: HermitC -> Id -> Bool +inScope c v = (v `boundIn` c) || -- defined in this module + case unfoldingInfo (idInfo v) of + CoreUnfolding {} -> True -- defined elsewhere + _ -> False +-- | Lookup a rule and attempt to construct a corresponding rewrite. rules :: String -> RewriteH CoreExpr rules r = do theRules <- getHermitRules @@ -245,8 +327,8 @@ Nothing -> fail $ "failed to find rule: " ++ show r Just rr -> rulesToRewriteH rr -getHermitRules :: (Generic a ~ Core) => TranslateH a [(String, [CoreRule])] -getHermitRules = translate $ \ env _e -> do +getHermitRules :: TranslateH a [(String, [CoreRule])] +getHermitRules = translate $ \ env _ -> do rb <- liftCoreM getRuleBase let other_rules = [ rule | top_bnds <- mg_binds (hermitModGuts env) @@ -283,9 +365,9 @@ , (v,e) <- case top_bnds of Rec bnds -> bnds NonRec b e -> [(b,e)] - , nm `GHC.cmpTHName2Id` v + , nm `cmpTHName2Var` v ] of - [] -> fail $ "can not find binding " ++ show nm + [] -> fail $ "cannot find binding " ++ show nm [(v,e)] -> return $ modGuts { mg_rules = mg_rules modGuts ++ [makeRule rule_name v e] } @@ -293,29 +375,14 @@ ---------------------------------------------------------------------- -flattenModule :: RewriteH ModGuts -flattenModule = modGutsR mergeBinds - -mergeBinds :: RewriteH CoreProgram -mergeBinds = contextfreeT $ \ binds -> - let allbinds = foldr listOfBinds [] binds - nodups = nub $ map fst allbinds - in - if (length allbinds == length nodups) - then return $ [Rec allbinds] - else fail "Module top level bindings contain multiple occurances of a name" - where listOfBinds cb others = case cb of - (NonRec b e) -> (b, e) : others - (Rec bds) -> bds ++ others - ----------------------------------------------------------------------- - +-- | Performs dependency anlaysis on an expression. +-- This can be useful to simplify a non-recursive recursive binding group to a non-recursive binding group. occurAnalyseExpr :: CoreExpr -> CoreExpr occurAnalyseExpr = OccurAnal.occurAnalyseExpr - +-- | Lifted version of 'occurAnalyseExpr' occurAnalyseExprR :: RewriteH CoreExpr -occurAnalyseExprR = contextfreeT $ \ exp -> return (occurAnalyseExpr exp) +occurAnalyseExprR = arr occurAnalyseExpr @@ -330,12 +397,6 @@ -} -{- -joinT :: TranslateH a (TranslateH b c) -> (a -> TranslateH b c) -joinT f e0 = translate $ \ c e1 -> do - t <- apply f c e0 - apply t c e1 --} exprEqual :: CoreExpr -> CoreExpr -> Bool exprEqual e1 e2 = eqExpr (mkInScopeSet $ exprsFreeVars [e1, e2]) e1 e2 @@ -361,25 +422,24 @@ coreEqual :: Core -> Core -> Maybe Bool coreEqual (ExprCore e1) (ExprCore e2) = Just $ e1 `exprEqual` e2 coreEqual (BindCore b1) (BindCore b2) = b1 `bindEqual` b2 -coreEqual (DefCore dc1) (DefCore dc2) = defToRecBind [dc1] `bindEqual` defToRecBind [dc2] +coreEqual (DefCore dc1) (DefCore dc2) = defsToRecBind [dc1] `bindEqual` defsToRecBind [dc2] coreEqual _ _ = Nothing compareValues :: TH.Name -> TH.Name -> TranslateH Core () compareValues n1 n2 = do p1 <- onePathToT (namedBinding n1) p2 <- onePathToT (namedBinding n2) - e1 :: Core <- pathT p1 idR - e2 :: Core <- pathT p2 idR + e1 <- pathT p1 idR + e2 <- pathT p2 idR case e1 `coreEqual` e2 of - Nothing -> fail $ show n1 ++ " and " ++ show n2 ++ " are incomparable" - Just False -> fail $ show n1 ++ " and " ++ show n2 ++ " are not equal" + Nothing -> fail $ show n1 ++ " and " ++ show n2 ++ " are incomparable." + Just False -> fail $ show n1 ++ " and " ++ show n2 ++ " are not equal." Just True -> return () -------------------------------------------------------- - --- try figure out the arity of an Id -arityOf:: Context -> Id -> Int +-- | Try to figure out the arity of an identifier. +arityOf :: HermitC -> Id -> Int arityOf env nm = case lookupHermitBinding nm env of Nothing -> idArity nm @@ -387,8 +447,8 @@ -- Note: the exprArity will call idArity if -- it hits an id; perhaps we should do the counting -- The advantage of idArity is it will terminate, though. - Just (BIND _ _ e) -> GHC.exprArity e - Just (CASE _ e _) -> GHC.exprArity e + Just (BIND _ _ e) -> exprArity e + Just (CASE _ e _) -> exprArity e ------------------------------------------- diff --git a/src/Language/HERMIT/Primitive/Inline.hs b/src/Language/HERMIT/Primitive/Inline.hs --- a/src/Language/HERMIT/Primitive/Inline.hs +++ b/src/Language/HERMIT/Primitive/Inline.hs @@ -1,20 +1,34 @@ -module Language.HERMIT.Primitive.Inline where +module Language.HERMIT.Primitive.Inline + ( -- * Inlining + externals + , inline + , inlineName + , inlineScrutinee + , inlineCaseBinder + , inlineTargets + ) +where + import GhcPlugins import Control.Arrow -import Language.HERMIT.GHC -import Language.HERMIT.Primitive.Common --- import Language.HERMIT.Primitive.Debug (traceR) -import Language.HERMIT.Primitive.GHC -import Language.HERMIT.Primitive.Unfold +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.Context +import Language.HERMIT.GHC import Language.HERMIT.External +import Language.HERMIT.Primitive.Common +import Language.HERMIT.Primitive.GHC hiding (externals) +import Language.HERMIT.Primitive.Unfold hiding (externals) + import qualified Language.Haskell.TH as TH +------------------------------------------------------------------------ + +-- | 'External's for inlining variables. externals :: [External] externals = [ external "inline" (promoteExprR inline :: RewriteH Core) @@ -29,20 +43,26 @@ [ "Inline if this variable is a case binder." ].+ Eval .+ Deep .+ Bash .+ TODO ] +------------------------------------------------------------------------ + +-- | If the current variable matches the given name, then inline it. inlineName :: TH.Name -> RewriteH CoreExpr inlineName nm = let name = TH.nameBase nm in prefixFailMsg ("inline '" ++ name ++ " failed: ") $ withPatFailMsg (wrongExprForm "Var v") $ do Var v <- idR - guardMsg (cmpTHName2Id nm v) $ name ++ " does not match " ++ var2String v ++ "." + guardMsg (cmpTHName2Var nm v) $ " does not match " ++ var2String v ++ "." inline +-- | Inline the current variable. inline :: RewriteH CoreExpr inline = configurableInline False False +-- | Inline the current variable, using the scrutinee rather than the case alternative if it is a case wild-card binder. inlineScrutinee :: RewriteH CoreExpr inlineScrutinee = configurableInline True False +-- | If the current variable is a case wild-card binder, then inline it. inlineCaseBinder :: RewriteH CoreExpr inlineCaseBinder = configurableInline False True @@ -74,6 +94,6 @@ -- | Get list of possible inline targets. Used by shell for completion. inlineTargets :: TranslateH Core [String] -inlineTargets = collectT $ promoteT $ ifM (testM inline) - (varT unqualifiedIdName) - (fail "cannot be inlined.") +inlineTargets = collectT $ promoteT $ whenM (testM inline) (varT unqualifiedVarName) + +------------------------------------------------------------------------ diff --git a/src/Language/HERMIT/Primitive/Kure.hs b/src/Language/HERMIT/Primitive/Kure.hs --- a/src/Language/HERMIT/Primitive/Kure.hs +++ b/src/Language/HERMIT/Primitive/Kure.hs @@ -7,6 +7,7 @@ import Control.Arrow +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External @@ -65,6 +66,8 @@ , external "not" (notM :: TranslateH Core () -> TranslateH Core ()) [ "cause a failing check to succeed, a succeeding check to fail" ] .+ Predicate ] + +------------------------------------------------------------------------------------ hfocusR :: TranslateH Core Path -> RewriteH Core -> RewriteH Core hfocusR tp r = do p <- tp diff --git a/src/Language/HERMIT/Primitive/Local.hs b/src/Language/HERMIT/Primitive/Local.hs --- a/src/Language/HERMIT/Primitive/Local.hs +++ b/src/Language/HERMIT/Primitive/Local.hs @@ -1,56 +1,100 @@ --- Andre Santos' Local Transformations (Ch 3 in his dissertation) -module Language.HERMIT.Primitive.Local where +module Language.HERMIT.Primitive.Local + ( -- * Local Structural Manipulations + Language.HERMIT.Primitive.Local.externals + -- ** Let Expressions + , module Language.HERMIT.Primitive.Local.Let + -- ** Case Expressions + , module Language.HERMIT.Primitive.Local.Case + -- ** Miscellaneous + , abstract + , nonrecToRec + , betaReduce + , betaReducePlus + , betaExpand + , etaReduce + , etaExpand + , multiEtaExpand + , flattenModule + , flattenProgramR + , flattenProgramT + ) +where import GhcPlugins +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.External import Language.HERMIT.GHC import Language.HERMIT.Primitive.GHC --- import Language.HERMIT.Primitive.Debug - import Language.HERMIT.Primitive.Common -import qualified Language.HERMIT.Primitive.Local.Case as Case -import qualified Language.HERMIT.Primitive.Local.Let as Let +import Language.HERMIT.Primitive.Local.Case +import Language.HERMIT.Primitive.Local.Let import qualified Language.Haskell.TH as TH +import Data.List(nub) + import Control.Arrow ------------------------------------------------------------------------------ +-- | Externals for local structural manipulations. +-- (Many taken from Chapter 3 of Andre Santos' dissertation.) externals :: [External] externals = - [ external "beta-reduce" (promoteExprR betaReduce :: RewriteH Core) - [ "((\\ v -> E1) E2) ==> let v = E2 in E1, fails otherwise" - , "this form of beta reduction is safe if E2 is an arbitrary" + [ external "nonrec-to-rec" (promoteBindR nonrecToRec :: RewriteH Core) + [ "convert a non-recursive binding into a recursive binding group with a single definition." + , "NonRec v e ==> Rec [Def v e]" ] + , external "beta-reduce" (promoteExprR betaReduce :: RewriteH Core) + [ "((\\ v -> E1) E2) ==> let v = E2 in E1" + , "this form of beta-reduction is safe if E2 is an arbitrary" , "expression (won't duplicate work)" ] .+ Eval .+ Shallow , external "beta-reduce-plus" (promoteExprR betaReducePlus :: RewriteH Core) - [ "perform one or more beta-reductions"] .+ Eval .+ Shallow .+ Bash + [ "perform one or more beta-reductions."] .+ Eval .+ Shallow .+ Bash , external "beta-expand" (promoteExprR betaExpand :: RewriteH Core) - [ "(let v = E1 in E2) ==> (\\ v -> E2) E1, fails otherwise" ] .+ Shallow - , external "dead-code-elimination" (promoteExprR dce :: RewriteH Core) - [ "dead code elimination removes a let." - , "(let v = E1 in E2) ==> E2, if v is not free in E2, fails otherwise" - , "condition: let is not-recursive" ] .+ Eval .+ Shallow .+ Bash + [ "(let v = e1 in e2) ==> (\\ v -> e2) e1" ] .+ Shallow , external "eta-reduce" (promoteExprR etaReduce :: RewriteH Core) - [ "(\\ v -> E1 v) ==> E1, fails otherwise" ] .+ Eval .+ Shallow .+ Bash + [ "(\\ v -> e1 v) ==> e1" ] .+ Eval .+ Shallow .+ Bash , external "eta-expand" (promoteExprR . etaExpand :: TH.Name -> RewriteH Core) - [ "'eta-expand v' performs E1 ==> (\\ v -> E1 v), fails otherwise" ] .+ Shallow .+ Introduce + [ "\"eta-expand 'v\" performs e1 ==> (\\ v -> e1 v)" ] .+ Shallow .+ Introduce + , external "flatten-module" (promoteModGutsR flattenModule :: RewriteH Core) + ["Flatten all the top-level binding groups in the module to a single recursive binding group.", + "This can be useful if you intend to appply GHC RULES."] + , external "flatten-program" (promoteProgR flattenProgramR :: RewriteH Core) + ["Flatten all the top-level binding groups in a program (list of binding groups) to a single recursive binding group.", + "This can be useful if you intend to appply GHC RULES."] + , external "abstract" (promoteExprR . abstract :: TH.Name -> RewriteH Core) + [ "Abstract over a variable using a lambda.", + "e ==> (\\ x -> e) x" + ] .+ Shallow .+ Introduce .+ Context ] - ++ Let.externals - ++ Case.externals + ++ letExternals + ++ caseExternals ------------------------------------------------------------------------------ +-- | NonRec v e ==> Rec [Def v e] +nonrecToRec :: RewriteH CoreBind +nonrecToRec = prefixFailMsg "Converting non-recursive binding to recursive binding failed: " $ + setFailMsg (wrongExprForm "NonRec v e") $ + do NonRec v e <- idR + guardMsg (isId v) "type variables cannot be defined recursively." + return $ Rec [(v,e)] + +------------------------------------------------------------------------------ + +-- | ((\\ v -> e1) e2) ==> (let v = e2 in e1) +-- This form of beta-reduction is safe if e2 is an arbitrary +-- expression (won't duplicate work). betaReduce :: RewriteH CoreExpr -betaReduce = prefixFailMsg "Beta reduction failed: " $ - setFailMsg (wrongExprForm "App (Lam v e1) e2") $ +betaReduce = setFailMsg ("Beta-reduction failed: " ++ wrongExprForm "App (Lam v e1) e2") $ do App (Lam v e1) e2 <- idR return $ Let (NonRec v e2) e1 + multiBetaReduce :: (Int -> Bool) -> RewriteH CoreExpr multiBetaReduce p = prefixFailMsg "Multi-Beta-Reduce failed: " $ do @@ -69,6 +113,8 @@ $ mkLams vs2 e0 -- TODO: inline this everywhere +-- Neil: Are we sure we want to inline this? +-- | Perform one or more beta-reductions. betaReducePlus :: RewriteH CoreExpr betaReducePlus = multiBetaReduce (> 0) @@ -91,50 +137,73 @@ ) -} +-- | (let v = e1 in e2) ==> (\\ v -> e2) e1 betaExpand :: RewriteH CoreExpr -betaExpand = setFailMsg ("Beta expansion failed: " ++ wrongExprForm "Let (NonRec v e1) e2") $ - do Let (NonRec v e2) e1 <- idR - return $ App (Lam v e1) e2 +betaExpand = setFailMsg ("Beta-expansion failed: " ++ wrongExprForm "Let (NonRec v e1) e2") $ + do Let (NonRec v e1) e2 <- idR + return $ App (Lam v e2) e1 ------------------------------------------------------------------------------ +-- | (\\ v -> e1 v) ==> e1 etaReduce :: RewriteH CoreExpr -etaReduce = prefixFailMsg "Eta reduction failed: " $ - withPatFailMsg (wrongExprForm "Lam v1 (App f (Var v2))") $ - (do Lam v1 (App f (Var v2)) <- idR - guardMsg (v1 == v2) "the expression has the right form, but the variables are not equal." - guardMsg (v1 `notElem` coreExprFreeIds f) $ var2String v1 ++ " is free in the function being applied." - return f) <+ - (do Lam v1 (App f (Type ty)) <- idR - Just v2 <- return (getTyVar_maybe ty) - guardMsg (v1 == v2) "type variables are not equal." - guardMsg (v1 `notElem` coreExprFreeVars f) $ var2String v1 ++ " is free in the function being applied." - return f) +etaReduce = prefixFailMsg "Eta-reduction failed: " $ + withPatFailMsg (wrongExprForm "Lam v1 (App f e)") $ + do Lam v1 (App f e) <- idR + case e of + Var v2 -> guardMsg (v1 == v2) "the expression has the right form, but the variables are not equal." + Type ty -> case getTyVar_maybe ty of + Nothing -> fail "the argument expression is not a type variable." + Just v2 -> guardMsg (v1 == v2) "type variables are not equal." + _ -> fail "the argument expression is not a variable." + guardMsg (v1 `notElem` coreExprFreeIds f) $ var2String v1 ++ " is free in the function being applied." + return f +-- | e1 ==> (\\ v -> e1 v) etaExpand :: TH.Name -> RewriteH CoreExpr -etaExpand nm = prefixFailMsg "Eta expansion failed: " $ - contextfreeT $ \ e -> - case splitFunTy_maybe (exprType e) of - Just (arg_ty, _) -> do v1 <- newVarH (show nm) arg_ty - return $ Lam v1 (App e (Var v1)) - _ -> case splitForAllTy_maybe (exprType e) of - Just (v,_) -> do v1 <- newTypeVarH (show nm) (tyVarKind v) - return $ Lam v1 (App e (Type (mkTyVarTy v1))) - Nothing -> fail "TODO: Add useful error message here." +etaExpand nm = prefixFailMsg "Eta-expansion failed: " $ + contextfreeT $ \ e -> let ty = exprType e in + case splitFunTy_maybe ty of + Just (argTy, _) -> do v <- newIdH (show nm) argTy + return $ Lam v (App e (Var v)) + Nothing -> case splitForAllTy_maybe ty of + Just (tv,_) -> do v <- newTyVarH (show nm) (tyVarKind tv) + return $ Lam v (App e (Type (mkTyVarTy v))) + Nothing -> fail "type of expression is not a function or a forall." +-- | Perform multiple eta-expansions. multiEtaExpand :: [TH.Name] -> RewriteH CoreExpr multiEtaExpand [] = idR multiEtaExpand (nm:nms) = etaExpand nm >>> lamR (multiEtaExpand nms) ------------------------------------------------------------------------------ --- dead code elimination removes a let. --- (let v = E1 in E2) => E2, if v is not free in E2 -dce :: RewriteH CoreExpr -dce = prefixFailMsg "Dead code elimination failed: " $ - withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ - do Let (NonRec v _) e <- idR - guardMsg (v `notElem` coreExprFreeVars e) "Dead code elimination failed. No dead code to eliminate." - return e +-- | Flatten all the top-level binding groups in the module to a single recursive binding group. +flattenModule :: RewriteH ModGuts +flattenModule = modGutsR flattenProgramR + +-- | Flatten all the top-level binding groups in a program to a program containing a single recursive binding group. +flattenProgramR :: RewriteH CoreProg +flattenProgramR = do bnd <- flattenProgramT + return (bindsToProg [bnd]) + +-- | Flatten all the top-level binding groups in a program to a single recursive binding group. +flattenProgramT :: TranslateH CoreProg CoreBind +flattenProgramT = do bds <- arr (concatMap bindToIdExprs . progToBinds) + guardMsg (nodups $ map fst bds) "Top-level bindings contain multiple occurrences of a name." + return (Rec bds) + +nodups :: Eq a => [a] -> Bool +nodups as = length as == length (nub as) + +------------------------------------------------------------------------------ + +-- | Abstract over a variable using a lambda. +-- e ==> (\ x. e) x +abstract :: TH.Name -> RewriteH CoreExpr +abstract nm = prefixFailMsg "abstraction failed: " $ + do e <- idR + v <- findBoundVarT nm + return (App (Lam v e) (Var v)) ------------------------------------------------------------------------------ diff --git a/src/Language/HERMIT/Primitive/Local/Case.hs b/src/Language/HERMIT/Primitive/Local/Case.hs --- a/src/Language/HERMIT/Primitive/Local/Case.hs +++ b/src/Language/HERMIT/Primitive/Local/Case.hs @@ -1,8 +1,6 @@ --- Andre Santos' Local Transformations (Ch 3 in his dissertation) module Language.HERMIT.Primitive.Local.Case ( -- * Rewrites on Case Expressions - externals - , letFloatCase + caseExternals , caseFloatApp , caseFloatArg , caseFloatCase @@ -19,17 +17,17 @@ import Data.List import Control.Arrow -import Control.Applicative -import Language.HERMIT.GHC +import Language.HERMIT.Core +import Language.HERMIT.Monad import Language.HERMIT.Kure +import Language.HERMIT.GHC import Language.HERMIT.External -import Language.HERMIT.Monad import Language.HERMIT.Primitive.Common -import Language.HERMIT.Primitive.GHC hiding (externals) -import Language.HERMIT.Primitive.Inline hiding (externals) -import Language.HERMIT.Primitive.AlphaConversion hiding (externals) +import Language.HERMIT.Primitive.GHC +import Language.HERMIT.Primitive.Inline +import Language.HERMIT.Primitive.AlphaConversion import qualified Language.Haskell.TH as TH @@ -37,8 +35,8 @@ ------------------------------------------------------------------------------ -- | Externals relating to Case expressions. -externals :: [External] -externals = +caseExternals :: [External] +caseExternals = [ -- I'm not sure this is possible. In core, v2 can only be a Constructor, Lit, or DEFAULT -- In the last case, v1 is already inlined in e. So we can't construct v2 as a Var. -- external "case-elimination" (promoteR $ not_defined "case-elimination" :: RewriteH Core) @@ -49,9 +47,7 @@ -- -- Again, don't think the lhs of this rule is possible to construct in core. -- , external "case-merging" (promoteR $ not_defined "case-merging" :: RewriteH Core) -- [ "case v of ...; d -> case v of alt -> e ==> case v of ...; alt -> e[v/d]" ] .+ Unimplemented .+ Eval - external "let-float-case" (promoteExprR letFloatCase :: RewriteH Core) - [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ] .+ Commute .+ Shallow .+ Eval .+ Bash - , external "case-float-app" (promoteExprR caseFloatApp :: RewriteH Core) + external "case-float-app" (promoteExprR caseFloatApp :: RewriteH Core) [ "(case ec of alt -> e) v ==> case ec of alt -> e v" ] .+ Commute .+ Shallow .+ Bash , external "case-float-arg" (promoteExprR caseFloatArg :: RewriteH Core) [ "f (case s of alt -> e) ==> case s of alt -> f e" ] .+ Commute .+ Shallow .+ PreCondition @@ -72,26 +68,15 @@ , "applications for all occurances of the named variable." ] ] --- not_defined :: String -> RewriteH CoreExpr --- not_defined nm = fail $ nm ++ " not implemented!" - --- | case (let v = e1 in e2) of alts ==> let v = e1 in case e2 of alts -letFloatCase :: RewriteH CoreExpr -letFloatCase = prefixFailMsg "Let floating from Case failed: " $ - do - captures <- caseT letVarsT (const (pure ())) $ \ vs _ _ _ -> vs - cFrees <- freeVarsT -- so we get type variables too - caseT (if null (cFrees `intersect` captures) then idR else alphaLet) - (const idR) - (\ (Let bnds e) b ty alts -> Let bnds (Case e b ty alts)) +------------------------------------------------------------------------------ -- | (case s of alt1 -> e1; alt2 -> e2) v ==> case s of alt1 -> e1 v; alt2 -> e2 v caseFloatApp :: RewriteH CoreExpr caseFloatApp = prefixFailMsg "Case floating from App function failed: " $ do - captures <- appT caseAltVarsT freeVarsT (flip (map . intersect)) - binderCapture <- appT caseBinderVarT freeVarsT intersect - appT ((if null binderCapture then idR else alphaCaseBinder Nothing) + captures <- appT caseAltVarsT freeVarsT (flip (map . intersect)) + wildCapture <- appT caseWildVarT freeVarsT elem + appT ((if not wildCapture then idR else alphaCaseBinder Nothing) >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt) ) idR @@ -104,10 +89,10 @@ caseFloatArg :: RewriteH CoreExpr caseFloatArg = prefixFailMsg "Case floating from App argument failed: " $ do - captures <- appT freeVarsT caseAltVarsT (map . intersect) - binderCapture <- appT freeVarsT caseBinderVarT intersect + captures <- appT freeVarsT caseAltVarsT (map . intersect) + wildCapture <- appT freeVarsT caseWildVarT (flip elem) appT idR - ((if null binderCapture then idR else alphaCaseBinder Nothing) + ((if not wildCapture then idR else alphaCaseBinder Nothing) >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt) ) (\f (Case s b _ty alts) -> let newTy = exprType (App f (case head alts of (_,_,e) -> e)) @@ -122,15 +107,15 @@ caseFloatCase :: RewriteH CoreExpr caseFloatCase = prefixFailMsg "Case floating from Case failed: " $ do - captures <- caseT caseAltVarsT (const altFreeVarsT) $ \ vss bndr _ fs -> map (intersect (concatMap ($ bndr) fs)) vss + captures <- caseT caseAltVarsT (const altFreeVarsExclWildT) (\ vss bndr _ fs -> map (intersect (concatMap ($ bndr) fs)) vss) -- does the binder of the inner case, shadow a free variable in any of the outer case alts? -- notice, caseBinderVarT returns a singleton list - binderCapture <- caseT caseBinderVarT (const altFreeVarsT) $ \ innerBindr bndr _ fs -> intersect (concatMap ($ bndr) fs) innerBindr - caseT ((if null binderCapture then idR else alphaCaseBinder Nothing) + wildCapture <- caseT caseWildVarT (const altFreeVarsExclWildT) (\ innerBndr bndr _ fvs -> innerBndr `elem` concatMap ($ bndr) fvs) + caseT ((if not wildCapture then idR else alphaCaseBinder Nothing) >>> caseAllR idR (\i -> if null (captures !! i) then idR else alphaAlt) ) (const idR) - (\ (Case s1 b1 ty1 alts1) b2 ty2 alts2 -> Case s1 b1 ty1 [ (c1, ids1, Case e1 b2 ty2 alts2) | (c1, ids1, e1) <- alts1 ]) + (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty [ (c1, ids1, Case e1 b2 ty alts2) | (c1, ids1, e1) <- alts1 ]) -- | let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e caseFloatLet :: RewriteH CoreExpr @@ -153,9 +138,13 @@ do Case s binder _ alts <- idR case isDataCon s of Nothing -> fail "head of scrutinee is not a data constructor." - Just (dc, args) -> case [ (bs, rhs) | (DataAlt dc', bs, rhs) <- alts, dc == dc' ] of - [(bs,e')] -> let valArgs = filter isValArg args -- discard any type arguments - in return $ nestedLets e' $ (binder, s) : zip bs valArgs + Just (dc, args) -> + case [ (bs, rhs) | (DataAlt dc', bs, rhs) <- alts, dc == dc' ] of + [(bs,e')] -> let (tyArgs, valArgs) = span isTypeArg args + tyBndrs = takeWhile isTyVar bs -- it is possible the pattern constructor binds a type + -- if the constructor is existentially quantified + existentials = reverse $ take (length tyBndrs) $ reverse tyArgs + in return $ nestedLets e' $ (binder, s) : zip bs (existentials ++ valArgs) [] -> fail "no matching alternative." _ -> fail "more than one matching alternative." @@ -182,14 +171,14 @@ caseSplit nm = do frees <- freeIdsT contextfreeT $ \ e -> - case [ i | i <- frees, cmpTHName2Id nm i ] of + case [ i | i <- frees, cmpTHName2Var nm i ] of [] -> fail "caseSplit: provided name is not free" (i:_) -> do let (tycon, tys) = splitTyConApp (idType i) dcs = tyConDataCons tycon aNms = map (:[]) $ cycle ['a'..'z'] dcsAndVars <- mapM (\dc -> do - as <- sequence [ newVarH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ] + as <- sequence [ newIdH a ty | (a,ty) <- zip aNms $ dataConInstArgTys dc tys ] return (dc,as)) dcs return $ Case (Var i) i (exprType e) [ (DataAlt dc, as, e) | (dc,as) <- dcsAndVars ] @@ -200,3 +189,4 @@ caseSplitInline :: TH.Name -> RewriteH Core caseSplitInline nm = promoteR (caseSplit nm) >>> anybuR (promoteExprR $ inlineName nm) +------------------------------------------------------------------------------ diff --git a/src/Language/HERMIT/Primitive/Local/Let.hs b/src/Language/HERMIT/Primitive/Local/Let.hs --- a/src/Language/HERMIT/Primitive/Local/Let.hs +++ b/src/Language/HERMIT/Primitive/Local/Let.hs @@ -1,11 +1,13 @@ --- Andre Santos' Local Transformations (Ch 3 in his dissertation) module Language.HERMIT.Primitive.Local.Let ( -- * Rewrites on Let Expressions - externals + letExternals , letIntro + , letElim , letFloatApp , letFloatArg , letFloatLet + , letFloatLam + , letFloatCase , letFloatExpr , letFloatLetTop , letToCase @@ -19,24 +21,31 @@ import Data.List import Data.Monoid -import Language.HERMIT.Kure +import Language.HERMIT.Core import Language.HERMIT.Monad +import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC import Language.HERMIT.Primitive.Common -import Language.HERMIT.Primitive.GHC hiding (externals) -import Language.HERMIT.Primitive.AlphaConversion hiding (externals) +import Language.HERMIT.Primitive.GHC +import Language.HERMIT.Primitive.AlphaConversion import qualified Language.Haskell.TH as TH ------------------------------------------------------------------------------ -- | Externals relating to Let expressions. -externals :: [External] -externals = +letExternals :: [External] +letExternals = [ external "let-intro" (promoteExprR . letIntro :: TH.Name -> RewriteH Core) [ "e => (let v = e in v), name of v is provided" ] .+ Shallow .+ Introduce + , external "dead-let-elimination" (promoteExprR letElim :: RewriteH Core) + [ "dead-let-elimination removes an unused let binding." + , "(let v = e1 in e2) ==> e2, if v is not free in e2." + , "condition: let is not-recursive" ] .+ Eval .+ Shallow .+ Bash + , external "dead-code-elimination" (promoteExprR letElim :: RewriteH Core) + [ "Synonym for dead-let-elimination [deprecated]" ] .+ Eval .+ Shallow -- TODO: delete this at some point -- , external "let-constructor-reuse" (promoteR $ not_defined "constructor-reuse" :: RewriteH Core) -- [ "let v = C v1..vn in ... C v1..vn ... ==> let v = C v1..vn in ... v ..., fails otherwise" ] .+ Unimplemented .+ Eval , external "let-float-app" (promoteExprR letFloatApp :: RewriteH Core) @@ -44,31 +53,53 @@ , external "let-float-arg" (promoteExprR letFloatArg :: RewriteH Core) [ "f (let v = ev in e) ==> let v = ev in f e" ] .+ Commute .+ Shallow .+ Bash , external "let-float-lam" (promoteExprR letFloatLam :: RewriteH Core) - [ "(\\ v1 -> let v2 = e1 in e2) ==> let v2 = e1 in (\\ v1 -> e2)", - "Fails if v1 occurs in e1.", + [ "(\\ v1 -> let v2 = e1 in e2) ==> let v2 = e1 in (\\ v1 -> e2), if v1 is not free in e2.", "If v1 = v2 then v1 will be alpha-renamed." ] .+ Commute .+ Shallow .+ Bash , external "let-float-let" (promoteExprR letFloatLet :: RewriteH Core) [ "let v = (let w = ew in ev) in e ==> let w = ew in let v = ev in e" ] .+ Commute .+ Shallow .+ Bash - , external "let-float-top" (promoteProgramR letFloatLetTop :: RewriteH Core) + , external "let-float-case" (promoteExprR letFloatCase :: RewriteH Core) + [ "case (let v = ev in e) of ... ==> let v = ev in case e of ..." ] .+ Commute .+ Shallow .+ Eval .+ Bash + , external "let-float-top" (promoteProgR letFloatLetTop :: RewriteH Core) [ "v = (let w = ew in ev) : bds ==> w = ew : v = ev : bds" ] .+ Commute .+ Shallow .+ Bash - , external "let-float" (promoteProgramR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core) + , external "let-float" (promoteProgR letFloatLetTop <+ promoteExprR letFloatExpr :: RewriteH Core) [ "Float a Let whatever the context." ] .+ Commute .+ Shallow .+ Bash , external "let-to-case" (promoteExprR letToCase :: RewriteH Core) [ "let v = ev in e ==> case ev of v -> e" ] .+ Commute .+ Shallow .+ PreCondition -- , external "let-to-case-unbox" (promoteR $ not_defined "let-to-case-unbox" :: RewriteH Core) -- [ "let v = ev in e ==> case ev of C v1..vn -> let v = C v1..vn in e" ] .+ Unimplemented - , external "nonrec-to-rec" (promoteBindR nonrecToRec :: RewriteH Core) - [ "convert a nonrec binding into a recursive binding group with a single binding" - , "NonRec v ev ==> Rec [(v,ev)]" ] ] +------------------------------------------------------------------------------------------- + -- | e => (let v = e in v), name of v is provided letIntro :: TH.Name -> RewriteH CoreExpr -letIntro nm = prefixFailMsg "Let introduction failed: " $ - contextfreeT $ \ e -> do letvar <- newVarH (show nm) (exprType e) - return $ Let (NonRec letvar e) (Var letvar) +letIntro nm = prefixFailMsg "Let-introduction failed: " $ + contextfreeT $ \ e -> do guardMsg (not $ isType e) "let expressions may not return a type." + v <- newIdH (show nm) (exprTypeOrKind e) + return $ Let (NonRec v e) (Var v) +-- | Remove an unused let binding. +-- (let v = E1 in E2) => E2, if v is not free in E2 +letElim :: RewriteH CoreExpr +letElim = prefixFailMsg "Dead-let-elimination failed: " $ + withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ + do Let (NonRec v _) e <- idR + guardMsg (v `notElem` coreExprFreeVars e) "let-bound variable appears in the expression." + return e + +-- | let v = ev in e ==> case ev of v -> e +letToCase :: RewriteH CoreExpr +letToCase = prefixFailMsg "Converting Let to Case failed: " $ + withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ + do Let (NonRec v ev) _ <- idR + guardMsg (not $ isType ev) "cannot case on a type." + nameModifier <- freshNameGenT Nothing + caseBndr <- constT (cloneVarH nameModifier v) + letT mempty (replaceVarR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')] + +------------------------------------------------------------------------------------------- + -- | (let v = ev in e) x ==> let v = ev in e x letFloatApp :: RewriteH CoreExpr letFloatApp = prefixFailMsg "Let floating from App function failed: " $ @@ -102,27 +133,28 @@ then alphaLam Nothing >>> letFloatLam else return (Let (NonRec v2 e1) (Lam v1 e2)) +-- | @case (let bnds in e) of wild alts ==> let bnds in (case e of wild alts)@ +-- Fails if any variables bound in @bnds@ occurs in @alts@. +letFloatCase :: RewriteH CoreExpr +letFloatCase = prefixFailMsg "Let floating from Case failed: " $ + do captures <- caseT letVarsT + (\ _ -> altFreeVarsExclWildT) + (\ vs wild _ fs -> vs `intersect` concatMap ($ wild) fs) + caseT (if null captures then idR else alphaLetVars captures) + (const idR) + (\ (Let bnds e) wild ty alts -> Let bnds (Case e wild ty alts)) + -- | Float a Let through an expression, whatever the context. letFloatExpr :: RewriteH CoreExpr letFloatExpr = setFailMsg "Unsuitable expression for Let floating." $ - letFloatApp <+ letFloatArg <+ letFloatLet <+ letFloatLam - --- | NonRec v (Let (NonRec w ew) ev) : bds ==> NonRec w ew : NonRec v ev : bds -letFloatLetTop :: RewriteH CoreProgram -letFloatLetTop = setFailMsg ("Let floating to top level failed: " ++ wrongExprForm "NonRec v (Let (NonRec w ew) ev) : bds") $ - do NonRec v (Let (NonRec w ew) ev) : bds <- idR - return (NonRec w ew : NonRec v ev : bds) + letFloatApp <+ letFloatArg <+ letFloatLet <+ letFloatLam <+ letFloatCase --- | let v = ev in e ==> case ev of v -> e -letToCase :: RewriteH CoreExpr -letToCase = prefixFailMsg "Converting Let to Case failed: " $ - withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ - do Let (NonRec v ev) _ <- idR - nameModifier <- freshNameGenT Nothing - caseBndr <- constT (cloneIdH nameModifier v) - letT mempty (renameIdR v caseBndr) $ \ () e' -> Case ev caseBndr (varType v) [(DEFAULT, [], e')] +-- | NonRec v (Let (NonRec w ew) ev) `ProgCons` p ==> NonRec w ew `ProgCons` NonRec v ev `ProgCons` p +letFloatLetTop :: RewriteH CoreProg +letFloatLetTop = prefixFailMsg "Let floating to top level failed: " $ + withPatFailMsg (wrongExprForm "NonRec v (Let (NonRec w ew) ev) `ProgCons` p") $ + do NonRec v (Let (NonRec w ew) ev) `ProgCons` p <- idR + guardMsg (not $ isType ew) "type bindings are not allowed at the top level." + return (NonRec w ew `ProgCons` NonRec v ev `ProgCons` p) -nonrecToRec :: RewriteH CoreBind -nonrecToRec = do - NonRec v ev <- idR - return $ Rec [(v,ev)] +------------------------------------------------------------------------------------------- diff --git a/src/Language/HERMIT/Primitive/Navigation.hs b/src/Language/HERMIT/Primitive/Navigation.hs --- a/src/Language/HERMIT/Primitive/Navigation.hs +++ b/src/Language/HERMIT/Primitive/Navigation.hs @@ -13,16 +13,17 @@ import GhcPlugins as GHC +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC import Control.Arrow -import Data.Monoid - import qualified Language.Haskell.TH as TH +--------------------------------------------------------------------------------------- + -- | 'External's involving navigating to named entities. externals :: [External] externals = map (.+ Navigation) @@ -38,6 +39,8 @@ [ "binding-group-of ' focuses on the binding group that binds the variable " ] ] +--------------------------------------------------------------------------------------- + -- | Find the path to the RHS of the binding group of the given name. bindingGroupOf :: TH.Name -> TranslateH Core Path bindingGroupOf = oneNonEmptyPathToT . bindGroup @@ -52,23 +55,30 @@ -- | Verify that this is a binding group defining the given name. bindGroup :: TH.Name -> Core -> Bool -bindGroup nm (BindCore (NonRec v _)) = nm `cmpTHName2Id` v -bindGroup nm (BindCore (Rec bds)) = any (cmpTHName2Id nm . fst) bds +bindGroup nm (BindCore (NonRec v _)) = nm `cmpTHName2Var` v +bindGroup nm (BindCore (Rec bds)) = any (cmpTHName2Var nm . fst) bds bindGroup _ _ = False -- | Verify that this is the definition of the given name. namedBinding :: TH.Name -> Core -> Bool -namedBinding nm (BindCore (NonRec v _)) = nm `cmpTHName2Id` v -namedBinding nm (DefCore (Def v _)) = nm `cmpTHName2Id` v +namedBinding nm (BindCore (NonRec v _)) = nm `cmpTHName2Var` v +namedBinding nm (DefCore (Def v _)) = nm `cmpTHName2Var` v namedBinding _ _ = False -- | Find all the possible targets of \"consider\". considerTargets :: TranslateH Core [String] -considerTargets = allT (collectT (promoteT $ nonRec <+ rec)) >>> arr concat - where nonRec = nonRecT mempty (\ v () -> [unqualifiedIdName v]) - rec = recT (const (arr (\ (Def v _) -> unqualifiedIdName v))) id +considerTargets = allT $ collectT (promoteBindT nonRec <+ promoteDefT def) + where + nonRec :: TranslateH CoreBind String + nonRec = nonRecT (return ()) constUnq + def :: TranslateH CoreDef String + def = defT (return ()) constUnq + constUnq :: Var -> () -> String + constUnq v () = unqualifiedVarName v + + data Considerable = Binding | Definition | CaseAlt | Variable | Literal | Application | Lambda | LetIn | CaseOf | Casty | Ticky | TypeVar | Coerce recognizedConsiderables :: String @@ -115,3 +125,5 @@ underConsideration TypeVar (ExprCore (Type _)) = True underConsideration Coerce (ExprCore (Coercion _)) = True underConsideration _ _ = False + +--------------------------------------------------------------------------------------- diff --git a/src/Language/HERMIT/Primitive/New.hs b/src/Language/HERMIT/Primitive/New.hs --- a/src/Language/HERMIT/Primitive/New.hs +++ b/src/Language/HERMIT/Primitive/New.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances #-} - -- Placeholder for new prims module Language.HERMIT.Primitive.New where @@ -7,41 +5,28 @@ import Control.Applicative import Control.Arrow -import Control.Monad -import Data.List(intercalate,intersect) +import Data.List(intersect) -import Language.HERMIT.Context +import Language.HERMIT.Core import Language.HERMIT.Monad import Language.HERMIT.Kure import Language.HERMIT.External import Language.HERMIT.GHC + +import Language.HERMIT.Primitive.Common import Language.HERMIT.Primitive.GHC -import Language.HERMIT.Primitive.Utils import Language.HERMIT.Primitive.Local -import Language.HERMIT.Primitive.Local.Case -import Language.HERMIT.Primitive.Local.Let import Language.HERMIT.Primitive.Inline -- import Language.HERMIT.Primitive.Debug import qualified Language.Haskell.TH as TH --- import Debug.Trace -import MonadUtils (MonadIO) -- GHC's MonadIO - externals :: [External] externals = map ((.+ Experiment) . (.+ TODO)) - [ external "info" (info :: TranslateH Core String) - [ "tell me what you know about this expression or binding" ] .+ Unimplemented - , external "expr-type" (promoteExprT exprTypeT :: TranslateH Core String) - [ "display the type of this expression"] - , external "test" (testQuery :: RewriteH Core -> TranslateH Core String) + [ external "test" (testQuery :: RewriteH Core -> TranslateH Core String) [ "determines if a rewrite could be successfully applied" ] - , external "fix-intro" (promoteDefR fixIntro :: RewriteH Core) - [ "rewrite a recursive binding into a non-recursive binding using fix" ] - , external "fix-spec" (promoteExprR fixSpecialization :: RewriteH Core) - [ "specialize a fix with a given argument"] .+ Shallow , external "cleanup-unfold" (promoteExprR cleanupUnfold :: RewriteH Core) [ "clean up immeduate nested fully-applied lambdas, from the bottom up"] , external "unfold" (promoteExprR . unfold :: TH.Name -> RewriteH Core) @@ -56,148 +41,62 @@ [ "var ' returns successfully for variable v, and fails otherwise.", "Useful in combination with \"when\", as in: when (var v) r" ] .+ Predicate , external "simplify" (simplifyR :: RewriteH Core) - [ "innermost (unfold '. <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ dead-code-elimination)" ] + [ "innermost (unfold '. <+ beta-reduce-plus <+ safe-let-subst <+ case-reduce <+ dead-let-elimination)" ] , external "let-tuple" (promoteExprR . letTupleR :: TH.Name -> RewriteH Core) [ "let x = e1 in (let y = e2 in e) ==> let t = (e1,e2) in (let x = fst t in (let y = snd t in e))" ] , external "any-call" (withUnfold :: RewriteH Core -> RewriteH Core) [ "any-call (.. unfold command ..) applies an unfold commands to all applications" , "preference is given to applications with more arguments" ] .+ Deep - , external "abstract" (promoteExprR . abstract :: TH.Name -> RewriteH Core) - [ "Abstract over a variable using a lambda.", - "e ==> (\\ x -> e) x" - ] .+ Shallow .+ Introduce .+ Context ] +------------------------------------------------------------------------------------------------------ +-- TODO: what about Type constructors around TyVars? isVar :: TH.Name -> TranslateH CoreExpr () -isVar nm = varT (cmpTHName2Id nm) >>= guardM +isVar nm = varT (cmpTHName2Var nm) >>= guardM +------------------------------------------------------------------------------------------------------ + simplifyR :: RewriteH Core -simplifyR = innermostR (promoteExprR (unfold (TH.mkName ".") <+ betaReducePlus <+ safeLetSubstR <+ caseReduce <+ dce)) +simplifyR = setFailMsg "Simplify failed: nothing to simplify." $ + innermostR (promoteExprR (unfold (TH.mkName ".") <+ betaReducePlus <+ safeLetSubstR <+ caseReduce <+ letElim)) --- This left for Neil's IFL presentation. letTupleR is the more general version. -letPairR :: TH.Name -> RewriteH CoreExpr -letPairR nm = do - Let (NonRec x e1) (Let (NonRec y e2) e) <- idR - ifM (letT (nonRecT (pure ()) const) - (letT (nonRecT freeVarsT (flip const)) (pure ()) const) - elem) - (fail "'x' is used in 'e2'") - (translate $ \ c _ -> do - tupleConId <- findId c "(,)" - fstId <- findId c "Data.Tuple.fst" - sndId <- findId c "Data.Tuple.snd" - let e1TyE = Type (exprType e1) - e2TyE = Type (exprType e2) - rhs = mkCoreApps (Var tupleConId) [e1TyE, e2TyE, e1, e2] - letId <- newVarH (show nm) (exprType rhs) - let fstE = mkCoreApps (Var fstId) [e1TyE, e2TyE, Var letId] - sndE = mkCoreApps (Var sndId) [e1TyE, e2TyE, Var letId] - return $ Let (NonRec letId rhs) - $ Let (NonRec x fstE) - $ Let (NonRec y sndE) e) -letTupleR :: TH.Name -> RewriteH CoreExpr -letTupleR nm = translate $ \ c e -> do - let collectLets :: CoreExpr -> ([(Id, CoreExpr)],CoreExpr) - collectLets (Let (NonRec x e1) e2) = let (bs,expr) = collectLets e2 - in ((x,e1):bs, expr) - collectLets expr = ([],expr) - - (bnds, body) = collectLets e - - guardMsg (length bnds > 1) "cannot tuple: need at least two nonrec lets" - - -- until we no longer need letPairR - if length bnds == 2 - then apply (letPairR nm) c e - else do - -- check if tupling the bindings would cause unbound variables - let (ids, rhss) = unzip bnds - - frees <- mapM (apply freeVarsT c) (drop 1 rhss) +collectLets :: CoreExpr -> ([(Var, CoreExpr)],CoreExpr) +collectLets (Let (NonRec x e1) e2) = let (bs,expr) = collectLets e2 in ((x,e1):bs, expr) +collectLets expr = ([],expr) - let used = concat $ zipWith intersect (map (flip take ids) [1..]) frees +-- | Combine nested non-recursive lets into case of a tuple. +letTupleR :: TH.Name -> RewriteH CoreExpr +letTupleR nm = prefixFailMsg "Let-tuple failed: " $ + do (bnds, body) <- arr collectLets + let numBnds = length bnds + guardMsg (numBnds > 1) "at least two non-recursive let bindings required." - if null used - then do - tupleConId <- findId c $ "(" ++ replicate (length bnds - 1) ',' ++ ")" + let (vs, rhss) = unzip bnds + guardMsg (all isId vs) "cannot tuple type variables." -- TODO: it'd be better if collectLets stopped on reaching a TyVar - let rhs = mkCoreApps (Var tupleConId) $ map (Type . exprType) rhss ++ rhss - varList = concat $ iterate (zipWith (flip (++)) $ repeat "0") $ map (:[]) ['a'..'z'] - dc <- maybe (fail "cannot find tuple datacon") return $ isDataConId_maybe tupleConId - vs <- zipWithM newVarH varList $ dataConInstOrigArgTys dc $ map exprType rhss + -- check if tupling the bindings would cause unbound variables + let + rhsTypes = map exprType rhss + frees = map coreExprFreeVars (drop 1 rhss) + used = concat $ zipWith intersect (map (`take` vs) [1..]) frees + if null used + then do tupleConId <- findIdT $ TH.mkName $ "(" ++ replicate (numBnds - 1) ',' ++ ")" + case isDataConId_maybe tupleConId of + Nothing -> fail "cannot find tuple data constructor." + Just dc -> let rhs = mkCoreApps (Var tupleConId) $ map Type rhsTypes ++ rhss + in constT $ do wild <- newIdH (show nm) (exprType rhs) + return $ Case rhs wild (exprType body) [(DataAlt dc, vs, body)] - letId <- newVarH (show nm) (exprType rhs) - return $ Let (NonRec letId rhs) - $ foldr (\ (i,(v,oe)) b -> Let (NonRec v (Case (Var letId) letId (exprType oe) [(DataAlt dc, vs, Var $ vs !! i)])) b) - body $ zip [0..] bnds - else fail "cannot tuple: some bindings are used in the rhs of others" + else fail $ "the following bound variables are used in subsequent bindings: " ++ showVars used -- Others -- let v = E1 in E2 E3 <=> (let v = E1 in E2) E3 -- let v = E1 in E2 E3 <=> E2 (let v = E1 in E3) --- A few Queries. - -info :: TranslateH Core String -info = translate $ \ c core -> do - dynFlags <- getDynFlags - let pa = "Path: " ++ show (contextPath c) - node = "Node: " ++ coreNode core - con = "Constructor: " ++ coreConstructor core - bds = "Bindings in Scope: " ++ (show $ map unqualifiedIdName $ listBindings c) - expExtra = case core of - ExprCore e -> ["Type: " ++ showExprType dynFlags e] ++ - ["Free Variables: " ++ showVars dynFlags (coreExprFreeVars e)] ++ - case e of - Var v -> ["Identifier Info: " ++ showIdInfo dynFlags v] - _ -> [] - _ -> [] - - return (intercalate "\n" $ [pa,node,con,bds] ++ expExtra) - -exprTypeT :: TranslateH CoreExpr String -exprTypeT = contextfreeT $ \ e -> do - dynFlags <- getDynFlags - return $ showExprType dynFlags e - -showExprType :: DynFlags -> CoreExpr -> String -showExprType dynFlags = showPpr dynFlags . exprType - -showIdInfo :: DynFlags -> Id -> String -showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo v - -coreNode :: Core -> String -coreNode (ModGutsCore _) = "Module" -coreNode (ProgramCore _) = "Program" -coreNode (BindCore _) = "Binding Group" -coreNode (DefCore _) = "Recursive Definition" -coreNode (ExprCore _) = "Expression" -coreNode (AltCore _) = "Case Alternative" - -coreConstructor :: Core -> String -coreConstructor (ModGutsCore _) = "ModGuts" -coreConstructor (ProgramCore prog) = case prog of - [] -> "[]" - (_:_) -> "(:)" -coreConstructor (BindCore bnd) = case bnd of - Rec _ -> "Rec" - NonRec _ _ -> "NonRec" -coreConstructor (DefCore _) = "Def" -coreConstructor (AltCore _) = "(,,)" -coreConstructor (ExprCore expr) = case expr of - Var _ -> "Var" - Type _ -> "Type" - Lit _ -> "Lit" - App _ _ -> "App" - Lam _ _ -> "Lam" - Let _ _ -> "Let" - Case _ _ _ _ -> "Case" - Cast _ _ -> "Cast" - Tick _ _ -> "Tick" - Coercion _ -> "Coercion" +------------------------------------------------------------------------------------------------------ testQuery :: RewriteH Core -> TranslateH Core String testQuery r = f <$> testM r @@ -205,80 +104,7 @@ f True = "Rewrite would succeed." f False = "Rewrite would fail." -findId :: (MonadUnique m, MonadIO m, MonadThings m, HasDynFlags m) => Context -> String -> m Id -findId c = findIdMG (hermitModGuts c) - -findIdMG :: (MonadUnique m, MonadIO m, MonadThings m, HasDynFlags m) => ModGuts -> String -> m Id -findIdMG modguts nm = - case filter isValName $ findNameFromTH (mg_rdr_env modguts) $ TH.mkName nm of - [] -> fail $ "cannot find " ++ nm - [n] -> lookupId n - ns -> do dynFlags <- getDynFlags - fail $ "too many " ++ nm ++ " found:\n" ++ intercalate ", " (map (showPpr dynFlags) ns) - --- | f = e ==> f = fix (\ f -> e) -fixIntro :: RewriteH CoreDef -fixIntro = prefixFailMsg "Fix introduction failed: " $ - do (c, Def f e) <- exposeT - constT $ do fixId <- findId c "Data.Function.fix" - f' <- cloneIdH id f - let coreFix = App (App (Var fixId) (Type (idType f))) - emptySub = mkEmptySubst (mkInScopeSet (exprFreeVars e)) - sub = extendSubst emptySub f (Var f') - return $ Def f (coreFix (Lam f' (substExpr (text "fixIntro") sub e))) - --- ironically, this is an instance of worker/wrapper itself. - -fixSpecialization :: RewriteH CoreExpr -fixSpecialization = do - fixId <- translate $ \ c _ -> findId c "Data.Function.fix" - - -- fix (t::*) (f :: t -> t) (a :: t) :: t - App (App (App (Var fx) (Type _)) _) _ <- idR - - guardMsg (fx == fixId) "fixSpecialization only works on fix" - - let rr :: RewriteH CoreExpr - rr = multiEtaExpand [TH.mkName "f",TH.mkName "a"] - - sub :: RewriteH Core - sub = pathR [0,1] (promoteR rr) - -- be careful this does not loop (it should not) - extractR sub >>> fixSpecialization' - - -fixSpecialization' :: RewriteH CoreExpr -fixSpecialization' = do - -- In normal form now - App (App (App (Var fx) (Type t)) - (Lam _ (Lam v2 (App (App e _) _a2))) - ) - a <- idR - - let t' = case a of - Type t2 -> applyTy t t2 - (Var x) | isTyVar x -> applyTy t (mkTyVarTy x) --- Var a2 -> mkAppTy t (exprType t2) --- mkAppTy t t' - - - -- TODO: t2' isn't used anywhere -- which means that a2 is never used ??? --- let t2' = case a2 of --- Type t2 -> applyTy t t2 --- Var a2 -> mkAppTy t (exprType t2) --- mkAppTy t t' - - - v3 <- constT $ newVarH "f" t' -- (funArgTy t') - v4 <- constT $ newTypeVarH "a" (tyVarKind v2) - - -- f' :: \/ a -> T [a] -> (\/ b . T [b]) - let f' = Lam v4 (Cast (Var v3) - (mkUnsafeCo t' (applyTy t (mkTyVarTy v4)))) - let e' = Lam v3 (App (App e f') a) - - return $ App (App (Var fx) (Type t')) e' - +------------------------------------------------------------------------------------------------------ -- | cleanupUnfold cleans a unfold operation -- (for example, an inline or rule application) @@ -313,6 +139,7 @@ rec :: RewriteH Core rec = withUnfold rr +------------------------------------------------------------------------------------------------------ -- | Push a function through a Case or Let expression. -- Unsafe if the function is not strict. @@ -321,7 +148,7 @@ do e <- idR case collectArgs e of (Var v,args) -> do - guardMsg (nm `cmpTHName2Id` v) $ "could not find name " ++ show nm + guardMsg (nm `cmpTHName2Var` v) $ "cannot find name " ++ show nm guardMsg (not $ null args) $ "no argument for " ++ show nm guardMsg (all isTypeArg $ init args) $ "initial arguments are not type arguments for " ++ show nm case last args of @@ -330,13 +157,4 @@ _ -> fail "argument is not a Case or Let." _ -> fail "no function to match." --- | Abstract over a variable using a lambda. --- e ==> (\ x. e) x -abstract :: TH.Name -> RewriteH CoreExpr -abstract nm = prefixFailMsg "abstraction failed: " $ - do (c,e) <- exposeT - let name = TH.nameBase nm - case filter (cmpTHName2Id nm) (listBindings c) of - [] -> fail $ name ++ " is not in scope." - [v] -> return (App (Lam v e) (Var v)) -- There might be issues if "v" is a type variable, I'm not sure. - _ : _ : _ -> fail $ "multiple variables named " ++ name ++ " in scope." +------------------------------------------------------------------------------------------------------ diff --git a/src/Language/HERMIT/Primitive/Unfold.hs b/src/Language/HERMIT/Primitive/Unfold.hs --- a/src/Language/HERMIT/Primitive/Unfold.hs +++ b/src/Language/HERMIT/Primitive/Unfold.hs @@ -13,7 +13,7 @@ import Language.HERMIT.Primitive.GHC hiding (externals) import Language.HERMIT.Primitive.Common -import Language.HERMIT.CoreExtra +import Language.HERMIT.Core import Language.HERMIT.Kure import Language.HERMIT.Monad import Language.HERMIT.External @@ -70,7 +70,7 @@ getUnfolding :: Monad m => Bool -- ^ Get the scrutinee instead of the patten match (for case binders). -> Bool -- ^ Only succeed if this variable is a case binder. - -> Id -> Context -> m (CoreExpr, Int) + -> Id -> HermitC -> m (CoreExpr, Int) getUnfolding scrutinee caseBinderOnly i c = case lookupHermitBinding i c of Nothing -> case unfoldingInfo (idInfo i) of diff --git a/src/Language/HERMIT/Primitive/Utils.hs b/src/Language/HERMIT/Primitive/Utils.hs deleted file mode 100644 --- a/src/Language/HERMIT/Primitive/Utils.hs +++ /dev/null @@ -1,12 +0,0 @@ - --- Utils for primitives, not the primitives themselves - -module Language.HERMIT.Primitive.Utils where - -import GhcPlugins as GHC - --- appCount counts the number of applications / arguments are present -appCount :: CoreExpr -> Int -appCount (App e1 _) = appCount e1 + 1 -appCount _ = 0 - diff --git a/src/Language/HERMIT/Shell/Command.hs b/src/Language/HERMIT/Shell/Command.hs --- a/src/Language/HERMIT/Shell/Command.hs +++ b/src/Language/HERMIT/Shell/Command.hs @@ -23,14 +23,16 @@ import qualified Data.Map as M import Data.Maybe +import Language.HERMIT.Core +import Language.HERMIT.Monad +import Language.HERMIT.Kure import Language.HERMIT.Dictionary import Language.HERMIT.Expr import Language.HERMIT.External import Language.HERMIT.Interp import Language.HERMIT.Kernel.Scoped -import Language.HERMIT.Kure -import Language.HERMIT.Monad import Language.HERMIT.PrettyPrinter + import Language.HERMIT.Primitive.Navigation import Language.HERMIT.Primitive.Inline @@ -43,13 +45,12 @@ import System.Console.Haskeline hiding (catch) --- There are 3 types of commands, AST effect-ful, Shell effect-ful, and Queries. +-- There are 4 types of commands, AST effect-ful, Shell effect-ful, Queries, and Meta-commands. -data ShellCommand :: * where - AstEffect :: AstEffect -> ShellCommand - ShellEffect :: ShellEffect -> ShellCommand - QueryFun :: QueryFun -> ShellCommand - MetaCommand :: MetaCommand -> ShellCommand +data ShellCommand = AstEffect AstEffect + | ShellEffect ShellEffect + | QueryFun QueryFun + | MetaCommand MetaCommand -- | AstEffects are things that are recorded in our log and saved files. @@ -60,8 +61,8 @@ | Pathfinder (TranslateH Core Path) -- | This changes the currect location using directions | Direction Direction - -- | This changes the current location using a give path - | PushFocus Path + -- | This changes the current location using a give path +-- | PushFocus Path | BeginScope | EndScope @@ -71,9 +72,9 @@ deriving Typeable instance Extern AstEffect where - type Box AstEffect = AstEffect - box i = i - unbox i = i + type Box AstEffect = AstEffect + box i = i + unbox i = i data ShellEffect :: * where SessionStateEffect :: (CommandLineState -> SessionState -> IO SessionState) -> ShellEffect @@ -89,9 +90,9 @@ deriving Typeable instance Extern QueryFun where - type Box QueryFun = QueryFun - box i = i - unbox i = i + type Box QueryFun = QueryFun + box i = i + unbox i = i data MetaCommand = Resume @@ -129,7 +130,6 @@ interpShellCommand :: [Interp ShellCommand] interpShellCommand = [ interp $ \ (ShellCommandBox cmd) -> cmd - , interp $ \ (IntBox i) -> AstEffect (PushFocus [i]) , interp $ \ (RewriteCoreBox rr) -> AstEffect (Apply rr) , interp $ \ (TranslateCorePathBox tt) -> AstEffect (Pathfinder tt) , interp $ \ (StringBox str) -> QueryFun (Message str) @@ -222,7 +222,7 @@ changeRenderer :: String -> ShellEffect changeRenderer renderer = SessionStateEffect $ \ _ st -> case lookup renderer finalRenders of - Nothing -> return st -- should fail with message + Nothing -> return st -- TODO: should fail with message Just r -> return $ st { cl_render = r } ---------------------------------------------------------------------------------- @@ -251,20 +251,20 @@ type CLM m a = ErrorT String (StateT CommandLineState m) a -- TODO: Come up with names for these, and/or better characterise these abstractions. -iokm2clm' :: MonadIO m => String -> (a -> CLM m b) -> IO (KureMonad a) -> CLM m b -iokm2clm' msg ret m = liftIO m >>= runKureMonad ret (throwError . (msg ++)) +iokm2clm' :: MonadIO m => String -> (a -> CLM m b) -> IO (KureM a) -> CLM m b +iokm2clm' msg ret m = liftIO m >>= runKureM ret (throwError . (msg ++)) -iokm2clm :: MonadIO m => String -> IO (KureMonad a) -> CLM m a +iokm2clm :: MonadIO m => String -> IO (KureM a) -> CLM m a iokm2clm msg = iokm2clm' msg return data CommandLineState = CommandLineState { cl_graph :: [(SAST,ExprH,SAST)] , cl_tags :: [(String,SAST)] -- these two should be in a reader - , cl_dict :: M.Map String [Dynamic] - , cl_kernel :: ScopedKernel + , cl_dict :: Dictionary + , cl_kernel :: ScopedKernel -- and the session state (perhaps in a seperate state?) - , cl_session :: SessionState + , cl_session :: SessionState } newSAST :: ExprH -> SAST -> CommandLineState -> CommandLineState @@ -274,14 +274,14 @@ -- Session-local issues; things that are never saved. data SessionState = SessionState - { cl_cursor :: SAST -- ^ the current AST - , cl_pretty :: String -- ^ which pretty printer to use - , cl_pretty_opts :: PrettyOptions -- ^ The options for the pretty printer + { cl_cursor :: SAST -- ^ the current AST + , cl_pretty :: String -- ^ which pretty printer to use + , cl_pretty_opts :: PrettyOptions -- ^ The options for the pretty printer , cl_render :: Handle -> PrettyOptions -> DocH -> IO () -- ^ the way of outputing to the screen - , cl_width :: Int -- ^ how wide is the screen? - , cl_nav :: Bool -- ^ keyboard input the the nav panel - , cl_loading :: Bool -- ^ if loading a file - , cl_tick :: TVar (M.Map String Int) -- ^ The list of ticked messages + , cl_width :: Int -- ^ how wide is the screen? + , cl_nav :: Bool -- ^ keyboard input the the nav panel + , cl_loading :: Bool -- ^ if loading a file + , cl_tick :: TVar (M.Map String Int) -- ^ The list of ticked messages } ------------------------------------------------------------------------------- @@ -292,7 +292,7 @@ | AmbiguousC [CompletionType] -- completionType function needs to be more specific deriving (Show) --- todo: reverse rPrev and parse it, to better figure out what possiblities are in context? +-- TODO: reverse rPrev and parse it, to better figure out what possiblities are in context? -- for instance, completing "any-bu (inline " should be different than completing just "inline " -- this would also allow typed completion? completionType :: String -> CompletionType @@ -324,7 +324,7 @@ -- $ queryS (cl_kernel st) (cl_cursor (cl_session st)) targetQuery -- TODO: I expect you want to build a silent version of the kernal_env for this query mcls <- queryS (cl_kernel st) (cl_cursor (cl_session st)) targetQuery (cl_kernel_env (cl_session st)) - cl <- runKureMonad return fail mcls -- TO DO: probably shouldn't use fail here. + cl <- runKureM return fail mcls -- TO DO: probably shouldn't use fail here. return $ (map simpleCompletion . nub . filter (so_far `isPrefixOf`)) cl -- | The first argument is a list of files to load. @@ -383,7 +383,7 @@ `ourCatch` (liftIO . putStrLn) >> loop' -ourCatch :: (MonadIO n) => CLM IO () -> (String -> CLM n ()) -> CLM n () +ourCatch :: MonadIO m => CLM IO () -> (String -> CLM m ()) -> CLM m () ourCatch m failure = do st <- get (res,st') <- liftIO $ runStateT (runErrorT m) st @@ -394,7 +394,7 @@ -evalStmts :: (MonadIO m) => [StmtH ExprH] -> CLM m () +evalStmts :: MonadIO m => [StmtH ExprH] -> CLM m () evalStmts = mapM_ evalExpr . scopes where scopes :: [StmtH ExprH] -> [ExprH] scopes [] = [] @@ -402,7 +402,7 @@ scopes (ScopeH s:ss) = (CmdName "{" : scopes s) ++ [CmdName "}"] ++ scopes ss -evalExpr :: (MonadIO m) => ExprH -> CLM m () +evalExpr :: MonadIO m => ExprH -> CLM m () evalExpr expr = do dict <- gets cl_dict case interpExprH dict interpShellCommand expr of @@ -437,20 +437,11 @@ performAstEffect (Direction dir) expr = do st <- get - -- This seems unnecassary. But if you restore it, note that it needs editing so that it doesn't print if we're loading a file. - -- child_count <- iokm2clm "Could not compute number of children:" $ queryS (cl_kernel st) (cl_cursor (cl_session st)) numChildrenT (cl_kernel_env (cl_session st)) - -- liftIO $ print (child_count, dir) ast <- iokm2clm "Invalid move: " $ modPathS (cl_kernel st) (cl_cursor $ cl_session st) (moveLocally dir) (cl_kernel_env $ cl_session st) put $ newSAST expr ast st -- something changed, to print showFocus -performAstEffect (PushFocus p) expr = do - st <- get - ast <- iokm2clm "Invalid push: " $ modPathS (cl_kernel st) (cl_cursor $ cl_session st) (extendLocalPath p) (cl_kernel_env $ cl_session st) - put $ newSAST expr ast st - showFocus - performAstEffect BeginScope expr = do st <- get ast <- liftIO $ beginScopeS (cl_kernel st) (cl_cursor (cl_session st)) @@ -471,14 +462,8 @@ st <- get -- TODO: Again, we may want a quiet version of the kernel_env liftIO (queryS (cl_kernel st) (cl_cursor $ cl_session st) q (cl_kernel_env $ cl_session st)) - >>= runKureMonad (\ () -> putStrToConsole $ unparseExprH expr ++ " [correct]") - (\ err -> fail $ unparseExprH expr ++ " [exception: " ++ err ++ "]") - -- correctness <- liftIO (try $ queryS (cl_kernel st) (cl_cursor (cl_session st)) q) - -- case correctness of - -- Right () -> do putStrToConsole $ unparseExprH expr ++ " [correct]" - -- Left (err :: IOException) - -- -> fail $ unparseExprH expr ++ " [exception: " ++ show err ++ "]" - + >>= runKureM (\ () -> putStrToConsole $ unparseExprH expr ++ " [correct]") + (\ err -> fail $ unparseExprH expr ++ " [exception: " ++ err ++ "]") ------------------------------------------------------------------------------- @@ -508,13 +493,6 @@ -- These two need to use Inquiry performQuery (Message msg) = liftIO (putStrLn msg) performQuery Display = showFocus - -- do - -- st <- get - -- liftIO $ do - -- ps <- pathS (cl_kernel st) (cl_cursor (cl_session st)) - -- putStrLn $ "Paths: " ++ show ps - -- print ("Graph",cl_graph st) - -- print ("This",cl_cursor (cl_session st)) ------------------------------------------------------------------------------- @@ -525,12 +503,12 @@ performMetaCommand (Dump fileName _pp renderer width) = do st <- get case (M.lookup (cl_pretty (cl_session st)) pp_dictionary,lookup renderer finalRenders) of - (Just pp, Just r) -> do doc <- iokm2clm "Bad pretty-printer or renderer option: " $ - queryS (cl_kernel st) (cl_cursor $ cl_session st) (pp (cl_pretty_opts $ cl_session st)) (cl_kernel_env $ cl_session st) - liftIO $ do h <- openFile fileName WriteMode - r h ((cl_pretty_opts $ cl_session st) { po_width = width }) doc - hClose h - _ -> throwError "dump: bad pretty-printer or renderer option" + (Just pp, Just r) -> do doc <- iokm2clm "Bad pretty-printer or renderer option: " $ + queryS (cl_kernel st) (cl_cursor $ cl_session st) (pp (cl_pretty_opts $ cl_session st)) (cl_kernel_env $ cl_session st) + liftIO $ do h <- openFile fileName WriteMode + r h ((cl_pretty_opts $ cl_session st) { po_width = width }) doc + hClose h + _ -> throwError "dump: bad pretty-printer or renderer option" performMetaCommand (LoadFile fileName) = do putStrToConsole $ "[loading " ++ fileName ++ "]" res <- liftIO $ try (readFile fileName) @@ -619,14 +597,14 @@ all_nds <- listS (cl_kernel st) if SAST n `elem` all_nds then return $ sess_st { cl_cursor = SAST n } - else fail $ "Can not find AST #" ++ show n + else fail $ "Cannot find AST #" ++ show n ++ "." GotoTag tag -> case lookup tag (cl_tags st) of Just sast -> return $ sess_st { cl_cursor = sast } - Nothing -> fail $ "Can not find tag " ++ show tag + Nothing -> fail $ "Cannot find tag " ++ show tag ++ "." Step -> do let ns = [ edge | edge@(s,_,_) <- cl_graph st, s == cl_cursor (cl_session st) ] case ns of - [] -> fail "Cannot step forward (no more steps)" + [] -> fail "Cannot step forward (no more steps)." [(_,cmd,d) ] -> do putStrLn $ "step : " ++ unparseExprH cmd return $ sess_st { cl_cursor = d } @@ -634,11 +612,11 @@ Back -> do let ns = [ edge | edge@(_,_,d) <- cl_graph st, d == cl_cursor (cl_session st) ] case ns of - [] -> fail "Cannot step backwards (no more steps)" + [] -> fail "Cannot step backwards (no more steps)." [(s,cmd,_) ] -> do putStrLn $ "back, unstepping : " ++ unparseExprH cmd return $ sess_st { cl_cursor = s } - _ -> fail "Cannot step backwards (multiple choices, impossible!)" + _ -> fail "Cannot step backwards (multiple choices, impossible!)." --------------------------------------------------------