Permalink
Browse files

Initial commit of version of supercompiler matching paper

  • Loading branch information...
0 parents commit eb8276f96edbe992c31fb272c674eae5e7079648 @batterseapower committed Jul 5, 2010
Showing with 4,460 additions and 0 deletions.
  1. +13 −0 .gitignore
  2. +65 −0 Core/FreeVars.hs
  3. +268 −0 Core/Parser.hs
  4. +80 −0 Core/Prelude.hs
  5. +85 −0 Core/Renaming.hs
  6. +250 −0 Core/Syntax.hs
  7. +65 −0 Evaluator/Evaluate.hs
  8. +48 −0 Evaluator/FreeVars.hs
  9. +23 −0 Evaluator/Syntax.hs
  10. +117 −0 GHC.hs
  11. +95 −0 IdSupply.hs
  12. +30 −0 LICENSE
  13. +88 −0 Main.hs
  14. +49 −0 Name.hs
  15. +79 −0 Renaming.hs
  16. +3 −0 Setup.hs
  17. +21 −0 StaticFlags.hs
  18. +174 −0 Supercompile/Drive.hs
  19. +165 −0 Supercompile/Match.hs
  20. +31 −0 Supercompile/Residualise.hs
  21. +429 −0 Supercompile/Split.hs
  22. +49 −0 Termination/Terminate.hs
  23. +326 −0 Utilities.hs
  24. +69 −0 examples/Prelude.core
  25. +47 −0 examples/Prelude.hs
  26. +42 −0 examples/PreludeTest.hs
  27. +17 −0 examples/compile-time/ConcatMap-01.core
  28. +19 −0 examples/compile-time/ConcatMap-02.core
  29. +21 −0 examples/compile-time/ConcatMap-03.core
  30. +23 −0 examples/compile-time/ConcatMap-04.core
  31. +25 −0 examples/compile-time/ConcatMap-05.core
  32. +27 −0 examples/compile-time/ConcatMap-06.core
  33. +29 −0 examples/compile-time/ConcatMap-07.core
  34. +31 −0 examples/compile-time/ConcatMap-08.core
  35. +33 −0 examples/compile-time/ConcatMap-09.core
  36. +35 −0 examples/compile-time/ConcatMap-10.core
  37. +37 −0 examples/compile-time/ConcatMap-11.core
  38. +39 −0 examples/compile-time/ConcatMap-12.core
  39. +45 −0 examples/compile-time/ConcatMap.core
  40. +32 −0 examples/compile-time/Generator-Simon.hs
  41. +36 −0 examples/compile-time/Generator.hs
  42. +13 −0 examples/compile-time/Simon-01.core
  43. +15 −0 examples/compile-time/Simon-02.core
  44. +17 −0 examples/compile-time/Simon-03.core
  45. +19 −0 examples/compile-time/Simon-04.core
  46. +21 −0 examples/compile-time/Simon-05.core
  47. +23 −0 examples/compile-time/Simon-06.core
  48. +25 −0 examples/compile-time/Simon-07.core
  49. +27 −0 examples/compile-time/Simon-08.core
  50. +29 −0 examples/compile-time/Simon-09.core
  51. +29 −0 examples/compile-time/Simon-09.hosc
  52. +19 −0 examples/compile-time/Simon-09.supero
  53. +31 −0 examples/compile-time/Simon-10.core
  54. +33 −0 examples/compile-time/Simon-11.core
  55. +35 −0 examples/compile-time/Simon-12.core
  56. +20 −0 examples/compile-time/Simon-Self.core
  57. +8 −0 examples/compile-time/generate
  58. +8 −0 examples/compile-time/generate-simon
  59. +45 −0 examples/imaginary/Bernouilli.core
  60. +12 −0 examples/imaginary/Bernouilli.hs
  61. +46 −0 examples/imaginary/DigitsOfE1.core
  62. +58 −0 examples/imaginary/DigitsOfE2.core
  63. +1 −0 examples/imaginary/DigitsOfE2.hs
  64. +28 −0 examples/imaginary/Exp3_8.core
  65. +3 −0 examples/imaginary/Exp3_8.hs
  66. +21 −0 examples/imaginary/Primes.core
  67. +1 −0 examples/imaginary/Primes.hs
  68. +33 −0 examples/imaginary/Queens-NoLiterals.core
  69. +13 −0 examples/imaginary/Queens-NoLiterals.hs
  70. +31 −0 examples/imaginary/Queens-Safer.core
  71. +3 −0 examples/imaginary/Queens-Safer.hs
  72. +31 −0 examples/imaginary/Queens.core
  73. +1 −0 examples/imaginary/Queens.hs
  74. +11 −0 examples/imaginary/RFib.core
  75. +1 −0 examples/imaginary/RFib.hs
  76. +17 −0 examples/imaginary/Tak-NoLiterals.core
  77. +6 −0 examples/imaginary/Tak-NoLiterals.hs
  78. +17 −0 examples/imaginary/Tak.core
  79. +1 −0 examples/imaginary/Tak.hs
  80. +46 −0 examples/imaginary/Wheel-Sieve1.core
  81. +4 −0 examples/imaginary/Wheel-Sieve1.hs
  82. +50 −0 examples/imaginary/Wheel-Sieve2.core
  83. +3 −0 examples/imaginary/Wheel-Sieve2.hs
  84. +10 −0 examples/imaginary/X2N1.core
  85. +10 −0 examples/imaginary/X2N1.hs
  86. +11 −0 examples/jason/Explode.core
  87. +3 −0 examples/jason/Explode.hs
  88. +11 −0 examples/neil/SumSquare.core
  89. +1 −0 examples/neil/SumSquare.hs
  90. +7 −0 examples/peter/Append.core
  91. +1 −0 examples/peter/Append.hs
  92. +12 −0 examples/peter/Factorial.core
  93. +1 −0 examples/peter/Factorial.hs
  94. +7 −0 examples/peter/Raytracer.core
  95. +1 −0 examples/peter/Raytracer.hs
  96. +24 −0 examples/peter/SumTree-NoLiterals.core
  97. +8 −0 examples/peter/SumTree-NoLiterals.hs
  98. +24 −0 examples/peter/SumTree.core
  99. +3 −0 examples/peter/SumTree.hs
  100. +18 −0 examples/peter/TreeFlip-NoLiterals.core
  101. +8 −0 examples/peter/TreeFlip-NoLiterals.hs
  102. +18 −0 examples/peter/TreeFlip.core
  103. +3 −0 examples/peter/TreeFlip.hs
  104. +8 −0 examples/peter/ZipMaps.core
  105. +1 −0 examples/peter/ZipMaps.hs
  106. +16 −0 examples/peter/ZipTreeMaps.core
  107. +4 −0 examples/peter/ZipTreeMaps.hs
  108. +9 −0 examples/toys/Ackermann.core
  109. +3 −0 examples/toys/BlackHole.core
  110. +3 −0 examples/toys/BlackHole2.core
  111. +13 −0 examples/toys/EvenDouble.core
  112. +1 −0 examples/toys/EvenDouble.hs
  113. +32 −0 examples/toys/FloatLetsFromCasesThatReferToUpdate.core
  114. +5 −0 examples/toys/GHCBug.core
  115. +1 −0 examples/toys/GHCBug.hs
  116. +14 −0 examples/toys/LetRec.core
  117. +14 −0 examples/toys/LetRecUpdateBinding.core
  118. +9 −0 examples/toys/MapMapFusion.core
  119. +13 −0 examples/toys/NaiveReverse.core
  120. +1 −0 examples/toys/NaiveReverse.hs
  121. +14 −0 examples/toys/PeterGen.core
  122. +1 −0 examples/toys/PeterGen.hs
  123. +9 −0 examples/toys/PeterGenEasy.core
  124. +8 −0 examples/toys/ReverseReverse.core
  125. +9 −0 examples/toys/SimpleLaziness.core
  126. +9 −0 examples/toys/ValueRecursion.core
  127. +7 −0 examples/trivial/Application.core
  128. +7 −0 examples/trivial/Compose.core
  129. +5 −0 examples/trivial/Data.core
  130. +7 −0 examples/trivial/Identity.core
  131. +5 −0 examples/trivial/Lists.core
  132. +9 −0 examples/trivial/TupleBinding.core
  133. +23 −0 supercompile.cabal
  134. +4 −0 test
13 .gitignore
@@ -0,0 +1,13 @@
+# Input/output pairs
+input/
+output/
+thrifty-output/
+
+# OS junk
+.DS_Store
+Thumbs.db
+
+# Cabal and Haskell stuff
+dist/
+*.hi
+*.o
65 Core/FreeVars.hs
@@ -0,0 +1,65 @@
+module Core.FreeVars where
+
+import Core.Syntax
+
+import Utilities
+
+import qualified Data.Set as S
+
+
+type FreeVars = S.Set Var
+type BoundVars = S.Set Var
+
+deleteList :: Ord a => [a] -> S.Set a -> S.Set a
+deleteList = flip $ foldr S.delete
+
+termFreeVars :: Term -> FreeVars
+termFreeVars (Term e) = termFreeVars' termFreeVars e
+
+taggedTermFreeVars :: TaggedTerm -> FreeVars
+taggedTermFreeVars (TaggedTerm (Tagged _ e)) = termFreeVars' taggedTermFreeVars e
+
+termFreeVars' :: (term -> FreeVars) -> TermF term -> FreeVars
+termFreeVars' _ (Var x) = S.singleton x
+termFreeVars' term (Value v) = valueFreeVars' term v
+termFreeVars' term (App e x) = S.insert x $ term e
+termFreeVars' term (PrimOp _ es) = S.unions $ map term es
+termFreeVars' term (Case e alts) = term e `S.union` altsFreeVars' term alts
+termFreeVars' term (LetRec xes e) = deleteList xs $ S.unions (map term es) `S.union` term e
+ where (xs, es) = unzip xes
+
+altConOpenFreeVars :: AltCon -> (BoundVars, FreeVars) -> (BoundVars, FreeVars)
+altConOpenFreeVars (DataAlt _ xs) (bvs, fvs) = (bvs `S.union` S.fromList xs, fvs)
+altConOpenFreeVars (LiteralAlt _) (bvs, fvs) = (bvs, fvs)
+altConOpenFreeVars (DefaultAlt mb_x) (bvs, fvs) = (maybe id S.insert mb_x bvs, fvs)
+
+altConFreeVars :: AltCon -> FreeVars -> FreeVars
+altConFreeVars (DataAlt _ xs) = deleteList xs
+altConFreeVars (LiteralAlt _) = id
+altConFreeVars (DefaultAlt mb_x) = maybe id S.delete mb_x
+
+altFreeVars :: Alt -> FreeVars
+altFreeVars = altFreeVars' termFreeVars
+
+altFreeVars' :: (term -> FreeVars) -> AltF term -> FreeVars
+altFreeVars' term (altcon, e) = altConFreeVars altcon $ term e
+
+altsFreeVars :: [Alt] -> FreeVars
+altsFreeVars = altsFreeVars' termFreeVars
+
+taggedAltsFreeVars :: [TaggedAlt] -> FreeVars
+taggedAltsFreeVars = altsFreeVars' taggedTermFreeVars
+
+altsFreeVars' :: (term -> FreeVars) -> [AltF term] -> FreeVars
+altsFreeVars' term = S.unions . map (altFreeVars' term)
+
+valueFreeVars :: Value -> FreeVars
+valueFreeVars = valueFreeVars' termFreeVars
+
+taggedValueFreeVars :: TaggedValue -> FreeVars
+taggedValueFreeVars = valueFreeVars' taggedTermFreeVars
+
+valueFreeVars' :: (term -> FreeVars) -> ValueF term -> FreeVars
+valueFreeVars' term (Lambda x e) = S.delete x $ term e
+valueFreeVars' _ (Data _ xs) = S.fromList xs
+valueFreeVars' _ (Literal _) = S.empty
268 Core/Parser.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE PatternGuards, TupleSections, ViewPatterns #-}
+module Core.Parser (parse) where
+
+import Core.Syntax
+import Core.Prelude
+
+import Name hiding (freshName)
+import qualified Name
+import StaticFlags
+import Utilities
+
+import qualified Data.Map as M
+
+import qualified Language.Haskell.Exts as LHE
+import Language.Preprocessor.Cpphs
+
+import System.Directory
+import System.FilePath (replaceExtension)
+
+
+parse :: FilePath -> IO (String, [(Var, Term)])
+parse path = do
+ -- Read and pre-process .core file
+ contents <- readFile path >>= cpp
+ unless qUIET $ putStrLn contents
+
+ -- Read and pre-process corresponding .hs file (if any)
+ let wrapper_path = replaceExtension path ".hs"
+ has_wrapper <- doesFileExist wrapper_path
+ wrapper <- if has_wrapper then readFile wrapper_path >>= cpp else return ""
+
+ -- Return parsed .core file
+ return (wrapper, moduleCore . LHE.fromParseResult . LHE.parseFileContentsWithMode (LHE.defaultParseMode { LHE.parseFilename = path, LHE.extensions = [LHE.CPP, LHE.MagicHash] }) $ contents)
+ where cpp = runCpphs (defaultCpphsOptions { boolopts = (boolopts defaultCpphsOptions) { locations = False }, defines = ("SUPERCOMPILE", "1") : defines defaultCpphsOptions }) path
+
+
+data ParseState = ParseState {
+ ids :: IdSupply,
+ dc_wrappers :: M.Map DataCon Var,
+ int_wrappers :: M.Map Integer Var,
+ char_wrappers :: M.Map Char Var,
+ prim_wrappers :: M.Map PrimOp Var
+ }
+
+initParseState :: ParseState
+initParseState = ParseState {
+ ids = parseIdSupply,
+ dc_wrappers = M.empty,
+ int_wrappers = M.empty,
+ char_wrappers = M.empty,
+ prim_wrappers = M.empty
+ }
+
+buildWrappers :: ParseState -> [(Var, Term)]
+buildWrappers ps
+ = [ (f, lambdas xs $ data_ dc xs)
+ | (dc, f) <- M.toList (dc_wrappers ps)
+ , let arity = dataConArity dc; xs = map (\i -> name $ "x" ++ show i) [1..arity] ] ++
+ [ (f, int i)
+ | (i, f) <- M.toList (int_wrappers ps) ] ++
+ [ (f, char c)
+ | (c, f) <- M.toList (char_wrappers ps) ] ++
+ [ (f, lam (name "x1") $ lam (name "x2") $ primOp pop [var (name "x1"), var (name "x2")])
+ | (pop, f) <- M.toList (prim_wrappers ps) ] ++
+ [ (name "error", lam (name "msg") $ case_ (var (name "prelude_error") `app` name "msg") []) ]
+ where
+ dataConArity "()" = 0
+ dataConArity "(,)" = 2
+ dataConArity "(,,)" = 3
+ dataConArity "(,,,)" = 4
+ dataConArity "[]" = 0
+ dataConArity "(:)" = 2
+ dataConArity "Left" = 1
+ dataConArity "Right" = 1
+ dataConArity "True" = 0
+ dataConArity "False" = 0
+ dataConArity "Just" = 1
+ dataConArity "Nothing" = 0
+ dataConArity "MkU" = 1 -- GHCBug
+ dataConArity "Z" = 0 -- Exp3_8
+ dataConArity "S" = 1 -- Exp3_8
+ dataConArity "Leaf" = 1 -- SumTree
+ dataConArity "Branch" = 2 -- SumTree
+ dataConArity "Empty" = 0 -- ZipTreeMaps
+ dataConArity "Node" = 3 -- ZipTreeMaps
+ dataConArity "Wheel1" = 2 -- Wheel-Sieve1
+ dataConArity "Wheel2" = 3 -- Wheel-Sieve2
+ dataConArity s = panic "dataConArity" (text s)
+
+newtype ParseM a = ParseM { unParseM :: ParseState -> (ParseState, a) }
+
+instance Functor ParseM where
+ fmap = liftM
+
+instance Monad ParseM where
+ return x = ParseM $ \s -> (s, x)
+ mx >>= fxmy = ParseM $ \s -> case unParseM mx s of (s, x) -> unParseM (fxmy x) s
+
+freshName :: String -> ParseM Name
+freshName n = ParseM $ \s -> let (ids', x) = Name.freshName (ids s) n in (s { ids = ids' }, x)
+
+freshFloatName :: String -> Term -> ParseM (Maybe (Var, Term), Name)
+freshFloatName _ (Term (Var x)) = return (Nothing, x)
+freshFloatName n e = freshName n >>= \x -> return (Just (x, e), x)
+
+nameIt :: Term -> (Var -> ParseM Term) -> ParseM Term
+nameIt e f = freshFloatName "a" e >>= \(mb_float, x) -> fmap (bind (maybeToList mb_float)) $ f x
+
+nameThem :: [Term] -> ([Var] -> ParseM Term) -> ParseM Term
+nameThem es f = mapM (freshFloatName "a") es >>= \(unzip -> (mb_es, xs)) -> fmap (bind (catMaybes mb_es)) $ f xs
+
+list :: [Term] -> ParseM Term
+list es = nameThem es $ \es_xs -> replicateM (length es) (freshName "list") >>= \cons_xs -> return $ uncurry bind $ foldr (\(cons_x, e_x) (floats, tl) -> ((cons_x, tl) : floats, cons e_x cons_x)) ([], nil) (cons_xs `zip` es_xs)
+
+dataConWrapper :: DataCon -> ParseM Var
+dataConWrapper = grabWrapper dc_wrappers (\s x -> s { dc_wrappers = x })
+
+intWrapper :: Integer -> ParseM Var
+intWrapper = grabWrapper int_wrappers (\s x -> s { int_wrappers = x })
+
+charWrapper :: Char -> ParseM Var
+charWrapper = grabWrapper char_wrappers (\s x -> s { char_wrappers = x })
+
+primWrapper :: PrimOp -> ParseM Var
+primWrapper = grabWrapper prim_wrappers (\s x -> s { prim_wrappers = x })
+
+grabWrapper :: Ord a
+ => (ParseState -> M.Map a Var) -> (ParseState -> M.Map a Var -> ParseState)
+ -> a -> ParseM Var
+grabWrapper get set what = do
+ mb_x <- ParseM $ \s -> (s, M.lookup what (get s))
+ case mb_x of Just x -> return x
+ Nothing -> freshName "wrap" >>= \x -> ParseM $ \s -> (set s (M.insert what x (get s)), x)
+
+runParseM :: ParseM a -> ([(Var, Term)], a)
+runParseM = first buildWrappers . flip unParseM initParseState
+
+
+moduleCore :: LHE.Module -> [(Var, Term)]
+moduleCore (LHE.Module _loc _name _ops _warntxt _mbexports _imports decls) = wrap_xes ++ xes
+ where (wrap_xes, xes) = runParseM $ declsCore decls
+
+
+declsCore :: [LHE.Decl] -> ParseM [(Name, Term)]
+declsCore = fmap concat . mapM declCore
+
+declCore :: LHE.Decl -> ParseM [(Name, Term)]
+declCore (LHE.FunBind [LHE.Match _loc n pats _mb_type@Nothing (LHE.UnGuardedRhs e) _binds@(LHE.BDecls where_decls)]) = do
+ let x = name (nameString n)
+ (ys, _bound_ns, build) = patCores pats
+ xes <- declsCore where_decls
+ e <- expCore e
+ return [(x, lambdas ys $ build $ bind xes e)]
+declCore (LHE.PatBind _loc pat _mb_ty@Nothing (LHE.UnGuardedRhs e) _binds@(LHE.BDecls where_decls)) = do
+ let (x, bound_ns, build) = patCore pat
+ xes <- declsCore where_decls
+ e <- expCore e
+ return $ (x, bind xes e) : [(n, build (var n)) | n <- bound_ns, n /= x]
+declCore d = panic "declCore" (text $ show d)
+
+expCore :: LHE.Exp -> ParseM Term
+expCore (LHE.Var qname) = qNameCore qname
+expCore (LHE.Con qname) = fmap var $ dataConWrapper $ qNameDataCon qname
+expCore (LHE.Lit lit) = literalCore lit
+expCore (LHE.NegApp e) = expCore $ LHE.App (LHE.Var (LHE.UnQual (LHE.Ident "negate"))) e
+expCore (LHE.App e1 e2) = expCore e2 >>= \e2 -> e2 `nameIt` \x2 -> fmap (`app` x2) $ expCore e1
+expCore (LHE.InfixApp e1 eop e2) = expCore e1 >>= \e1 -> e1 `nameIt` \x1 -> expCore e2 >>= \e2 -> e2 `nameIt` \x2 -> qopCore eop >>= \eop -> return $ apps eop [x1, x2]
+expCore (LHE.Let (LHE.BDecls binds) e) = do
+ xes <- declsCore binds
+ fmap (bind xes) $ expCore e
+expCore (LHE.If e1 e2 e3) = expCore e1 >>= \e1 -> liftM2 (if_ e1) (expCore e2) (expCore e3)
+expCore (LHE.Case e alts) = expCore e >>= \e -> fmap (case_ e) (mapM altCore alts)
+expCore (LHE.Tuple es) = mapM expCore es >>= flip nameThem (return . tuple)
+expCore (LHE.Paren e) = expCore e
+expCore (LHE.List es) = mapM expCore es >>= list
+expCore (LHE.Lambda _ ps e) = expCore e >>= \e -> return $ lambdas xs $ build e
+ where (xs, _bound_xs, build) = patCores ps
+expCore (LHE.LeftSection e1 eop) = expCore e1 >>= \e1 -> e1 `nameIt` \x1 -> qopCore eop >>= \eop -> return (eop `app` x1) -- NB: careful about sharing if you add Right sections!
+expCore (LHE.EnumFromThen e1 e2) = expCore $ LHE.Var (LHE.UnQual (LHE.Ident "enumFromThen")) `LHE.App` e1 `LHE.App` e2
+expCore e = panic "expCore" (text $ show e)
+
+qopCore :: LHE.QOp -> ParseM Term
+qopCore (LHE.QVarOp qn) = qNameCore qn
+qopCore (LHE.QConOp qn) = qNameCore qn
+
+literalCore :: LHE.Literal -> ParseM Term
+literalCore (LHE.Int i) = fmap var $ intWrapper i
+literalCore (LHE.Char c) = fmap var $ charWrapper c
+literalCore (LHE.String s) = mapM (literalCore . LHE.Char) s >>= list
+
+altCore :: LHE.Alt -> ParseM Alt
+altCore (LHE.Alt _loc pat (LHE.UnGuardedAlt e) (LHE.BDecls binds)) = do
+ xes <- declsCore binds
+ e <- expCore e
+ return (altcon, build (bind xes e))
+ where (altcon, build) = altPatCore pat
+
+altPatCore :: LHE.Pat -> (AltCon, Term -> Term)
+altPatCore (LHE.PApp qname pats) = dataAlt (qNameDataCon qname) (patCores pats)
+altPatCore (LHE.PInfixApp pat1 qname pat2) = dataAlt (qNameDataCon qname) (patCores [pat1, pat2])
+altPatCore (LHE.PTuple [pat1, pat2]) = dataAlt pairDataCon (patCores [pat1, pat2])
+altPatCore (LHE.PParen pat) = altPatCore pat
+altPatCore (LHE.PList []) = dataAlt nilDataCon ([], [], id)
+altPatCore (LHE.PLit (LHE.Int i)) = (LiteralAlt (Int i), id)
+altPatCore LHE.PWildCard = (DefaultAlt Nothing, id)
+altPatCore p = panic "altPatCore" (text $ show p)
+
+dataAlt :: DataCon -> ([Var], [Var], Term -> Term) -> (AltCon, Term -> Term)
+dataAlt dcon (names, _bound_ns, build) = (DataAlt dcon names, build)
+
+
+specialConDataCon :: LHE.SpecialCon -> DataCon
+specialConDataCon LHE.UnitCon = unitDataCon
+specialConDataCon LHE.ListCon = nilDataCon
+specialConDataCon (LHE.TupleCon LHE.Boxed 2) = pairDataCon
+specialConDataCon LHE.Cons = consDataCon
+
+nameString :: LHE.Name -> String
+nameString (LHE.Ident s) = s
+nameString (LHE.Symbol s) = s
+
+qNameCore :: LHE.QName -> ParseM Term
+qNameCore (LHE.UnQual n) = fmap var $ case nameString n of
+ "+" -> primWrapper Add
+ "-" -> primWrapper Subtract
+ "*" -> primWrapper Multiply
+ "div" -> primWrapper Divide
+ "mod" -> primWrapper Modulo
+ "==" -> primWrapper Equal
+ "<=" -> primWrapper LessThanEqual
+ s -> return (name s)
+qNameCore (LHE.Special sc) = fmap var $ dataConWrapper $ specialConDataCon sc
+qNameCore qn = panic "qNameCore" (text $ show qn)
+
+qNameDataCon :: LHE.QName -> DataCon
+qNameDataCon (LHE.UnQual name) = nameString name
+qNameDataCon (LHE.Special sc) = specialConDataCon sc
+
+patCores :: [LHE.Pat] -> ([Var], [Var], Term -> Term)
+patCores [] = ([], [], id)
+patCores (p:ps) = (n':ns', bound_ns' ++ bound_nss', build . build')
+ where (n', bound_ns', build) = patCore p
+ (ns', bound_nss', build') = patCores ps
+
+-- TODO: this function is a hilarious shadowing bug waiting to happen. Thread the IdSupply in here to generate temp names.
+patCore :: LHE.Pat -- Pattern
+ -> (Var, -- Name consumed by the pattern
+ [Var], -- Names bound by the pattern
+ Term -> Term) -- How to build the (strict) consuming context around the thing inside the pattern
+patCore (LHE.PVar n) = (x, [x], id)
+ where x = name (nameString n)
+patCore LHE.PWildCard = (x, [x], id)
+ where x = name "_"
+patCore (LHE.PParen p) = patCore p
+patCore (LHE.PTuple ps) = case tupleDataCon (length ps) of
+ Nothing | [p] <- ps -> patCore p
+ Just dc -> (n', bound_ns', \e -> case_ (var n') [(DataAlt dc ns', build e)])
+ where n' = name "tup"
+ (ns', bound_ns', build) = patCores ps
+patCore (LHE.PInfixApp p1 qinfix p2) = (n', bound_ns1 ++ bound_ns2, \e -> case_ (var n') [(DataAlt (qNameDataCon qinfix) [n1', n2'], build1 (build2 e))])
+ where n' = name "infx"
+ (n1', bound_ns1, build1) = patCore p1
+ (n2', bound_ns2, build2) = patCore p2
+patCore (LHE.PApp (LHE.Special LHE.UnitCon) []) = (name "unit", [], id)
+patCore p = panic "patCore" (text $ show p)
+
+bind :: [(Var, Term)] -> Term -> Term
+bind xes e = letRec xes e
80 Core/Prelude.hs
@@ -0,0 +1,80 @@
+module Core.Prelude where
+
+import Core.Syntax
+
+import Utilities
+
+
+lam :: Var -> Term -> Term
+lam = lambda
+
+int :: Integer -> Term
+int = literal . Int
+
+char :: Char -> Term
+char = literal . Char
+
+
+add :: Term -> Term -> Term
+add e1 e2 = primOp Add [e1, e2]
+
+
+nilDataCon, consDataCon :: DataCon
+nilDataCon = "[]"
+consDataCon = "(:)"
+
+nil :: Term
+nil = data_ nilDataCon []
+
+cons :: Var -> Var -> Term
+cons x xs = data_ consDataCon [x, xs]
+
+
+trueDataCon, falseDataCon :: DataCon
+trueDataCon = "True"
+falseDataCon = "False"
+
+true, false :: Term
+true = data_ trueDataCon []
+false = data_ falseDataCon []
+
+if_ :: Term -> Term -> Term -> Term
+if_ e et ef = case_ e [(DataAlt trueDataCon [], et), (DataAlt falseDataCon [], ef)]
+
+bool :: Bool -> Term
+bool x = if x then true else false
+
+
+nothingDataCon, justDataCon :: DataCon
+nothingDataCon = "Nothing"
+justDataCon = "Just"
+
+nothing :: Term
+nothing = data_ nothingDataCon []
+
+just :: Var -> Term
+just x = data_ justDataCon [x]
+
+
+jDataCon, sDataCon :: DataCon
+jDataCon = "J#"
+sDataCon = "S#"
+
+j_, s_ :: Var -> Term
+j_ x = data_ jDataCon [x]
+s_ x = data_ sDataCon [x]
+
+
+tupleDataCon :: Int -> Maybe DataCon
+tupleDataCon 1 = Nothing
+tupleDataCon n = Just $ '(' : replicate (n - 1) ',' ++ ")"
+
+unitDataCon, pairDataCon :: DataCon
+unitDataCon = fromJust $ tupleDataCon 0
+pairDataCon = fromJust $ tupleDataCon 2
+
+unit :: Term
+unit = tuple []
+
+tuple :: [Var] -> Term
+tuple xs = case tupleDataCon (length xs) of Nothing -> var (expectHead "tuple" xs); Just dc -> data_ dc xs
85 Core/Renaming.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE ViewPatterns, TupleSections #-}
+module Core.Renaming where
+
+import Core.Syntax
+
+import Renaming
+import Utilities
+
+
+type In a = (Renaming, a)
+type Out a = a
+
+
+renameTagged :: (IdSupply -> Renaming -> a -> a) -> IdSupply -> Renaming -> Tagged a -> Tagged a
+renameTagged f ids rn (Tagged tg x) = Tagged tg (f ids rn x)
+
+renameTaggedBinder :: (IdSupply -> Renaming -> a -> (IdSupply, Renaming, a)) -> IdSupply -> Renaming -> Tagged a -> (IdSupply, Renaming, Tagged a)
+renameTaggedBinder f ids rn (Tagged tg x) = third3 (Tagged tg) $ f ids rn x
+
+
+renameIn :: (IdSupply -> Renaming -> a -> a) -> IdSupply -> In a -> a
+renameIn f ids (rn, x) = f ids rn x
+
+renameInRenaming :: Renaming -> In a -> In a
+renameInRenaming rn_by (rn, x) = (renameRenaming rn_by rn, x)
+
+renameBounds :: (Var -> Var -> v) -> IdSupply -> Renaming -> [(Var, a)] -> (IdSupply, Renaming, [(v, In a)])
+renameBounds f ids rn (unzip -> (xs, es)) = (ids', rn', zipWith f xs xs' `zip` map (rn',) es)
+ where (ids', rn', xs') = renameBinders ids rn xs
+
+
+renameValue :: IdSupply -> Renaming -> Value -> Value
+renameValue = renameValue' renameTerm
+
+renameTaggedValue :: IdSupply -> Renaming -> TaggedValue -> TaggedValue
+renameTaggedValue = renameValue' renameTaggedTerm
+
+renameValue' :: (IdSupply -> Renaming -> term -> term)
+ -> IdSupply -> Renaming -> ValueF term -> ValueF term
+renameValue' term ids rn v = case v of
+ Lambda x e -> Lambda x' (term ids' rn' e)
+ where (ids', rn', x') = renameBinder ids rn x
+ Data dc xs -> Data dc (map (rename rn) xs)
+ Literal l -> Literal l
+
+renameTerm :: IdSupply -> Renaming -> Term -> Term
+renameTerm ids rn (Term e) = Term $ renameTerm' renameTerm ids rn e
+
+renameTaggedTerm :: IdSupply -> Renaming -> TaggedTerm -> TaggedTerm
+renameTaggedTerm ids rn (TaggedTerm e) = TaggedTerm $ renameTagged (renameTerm' renameTaggedTerm) ids rn e
+
+renameTerm' :: (IdSupply -> Renaming -> term -> term)
+ -> IdSupply -> Renaming -> TermF term -> TermF term
+renameTerm' term ids rn e = case e of
+ Var x -> Var (safeRename "renameTerm" rn x)
+ Value v -> Value (renameValue' term ids rn v)
+ App e1 x2 -> App (term ids rn e1) (rename rn x2)
+ PrimOp pop es -> PrimOp pop (map (term ids rn) es)
+ Case e alts -> Case (term ids rn e) (renameAlts' term ids rn alts)
+ LetRec xes e -> LetRec (map (second (renameIn term ids')) xes') (term ids' rn' e)
+ where (ids', rn', xes') = renameBounds (\_ x' -> x') ids rn xes
+
+renameAlt :: IdSupply -> Renaming -> Alt -> Alt
+renameAlt = renameAlt' renameTerm
+
+renameAlt' :: (IdSupply -> Renaming -> term -> term)
+ -> IdSupply -> Renaming -> AltF term -> AltF term
+renameAlt' term ids rn (alt_con, alt_e) = (alt_con', term ids' rn' alt_e)
+ where (ids', rn', alt_con') = renameAltCon ids rn alt_con
+
+renameAltCon :: IdSupply -> Renaming -> AltCon -> (IdSupply, Renaming, AltCon)
+renameAltCon ids rn_alt alt_con = case alt_con of
+ DataAlt alt_dc alt_xs -> third3 (DataAlt alt_dc) $ renameBinders ids rn_alt alt_xs
+ LiteralAlt _ -> (ids, rn_alt, alt_con)
+ DefaultAlt alt_mb_x -> maybe (ids, rn_alt, alt_con) (third3 (DefaultAlt . Just) . renameBinder ids rn_alt) alt_mb_x
+
+renameAlts :: IdSupply -> Renaming -> [Alt] -> [Alt]
+renameAlts = renameAlts' renameTerm
+
+renameTaggedAlts :: IdSupply -> Renaming -> [TaggedAlt] -> [TaggedAlt]
+renameTaggedAlts = renameAlts' renameTaggedTerm
+
+renameAlts' :: (IdSupply -> Renaming -> term -> term)
+ -> IdSupply -> Renaming -> [AltF term] -> [AltF term]
+renameAlts' term ids rn = map (renameAlt' term ids rn)
250 Core/Syntax.hs
@@ -0,0 +1,250 @@
+{-# LANGUAGE PatternGuards, ViewPatterns, TypeSynonymInstances, FlexibleInstances #-}
+module Core.Syntax where
+
+import Name
+import Utilities
+
+
+type Var = Name
+
+type DataCon = String
+
+data PrimOp = Add | Subtract | Multiply | Divide | Modulo | Equal | LessThanEqual
+ deriving (Eq, Ord, Show)
+
+data AltCon = DataAlt DataCon [Var] | LiteralAlt Literal | DefaultAlt (Maybe Var)
+ deriving (Eq, Show)
+
+data Literal = Int Integer | Char Char
+ deriving (Eq, Show)
+
+newtype Term = Term { unTerm :: TermF Term }
+ deriving (Eq, Show)
+data TaggedTerm = TaggedTerm { unTaggedTerm :: Tagged (TermF TaggedTerm) }
+ deriving (Eq, Show)
+data TermF term = Var Var | Value (ValueF term) | App term Var | PrimOp PrimOp [term] | Case term [AltF term] | LetRec [(Var, term)] term
+ deriving (Eq, Show)
+
+type Alt = AltF Term
+type TaggedAlt = AltF TaggedTerm
+type AltF term = (AltCon, term)
+
+type Value = ValueF Term
+type TaggedValue = ValueF TaggedTerm
+data ValueF term = Lambda Var term | Data DataCon [Var] | Literal Literal
+ deriving (Eq, Show)
+
+instance NFData PrimOp
+
+instance NFData AltCon where
+ rnf (DataAlt a b) = rnf a `seq` rnf b
+ rnf (LiteralAlt a) = rnf a
+ rnf (DefaultAlt a) = rnf a
+
+instance NFData Literal where
+ rnf (Int a) = rnf a
+ rnf (Char a) = rnf a
+
+instance NFData Term where
+ rnf (Term a) = rnf a
+
+instance NFData TaggedTerm where
+ rnf (TaggedTerm a) = rnf a
+
+instance NFData term => NFData (TermF term) where
+ rnf (Var a) = rnf a
+ rnf (Value a) = rnf a
+ rnf (App a b) = rnf a `seq` rnf b
+ rnf (PrimOp a b) = rnf a `seq` rnf b
+ rnf (Case a b) = rnf a `seq` rnf b
+ rnf (LetRec a b) = rnf a `seq` rnf b
+
+instance NFData term => NFData (ValueF term) where
+ rnf (Lambda a b) = rnf a `seq` rnf b
+ rnf (Data a b) = rnf a `seq` rnf b
+ rnf (Literal a) = rnf a
+
+instance Pretty PrimOp where
+ pPrint Add = text "(+)"
+ pPrint Subtract = text "(-)"
+ pPrint Multiply = text "(*)"
+ pPrint Divide = text "div"
+ pPrint Modulo = text "mod"
+ pPrint Equal = text "(==)"
+ pPrint LessThanEqual = text "(<=)"
+
+instance Pretty AltCon where
+ pPrintPrec level prec altcon = case altcon of
+ DataAlt dc xs -> prettyParen (prec >= appPrec) $ text dc <+> hsep (map (pPrintPrec level appPrec) xs)
+ LiteralAlt l -> pPrint l
+ DefaultAlt mb_x -> maybe (text "_") (pPrintPrec level prec) mb_x
+
+instance Pretty Literal where
+ pPrintPrec level prec (Int i) | level == haskellLevel = prettyParen (prec >= appPrec) $ pPrintPrec level appPrec i <+> text ":: Int"
+ | otherwise = pPrintPrec level prec i
+ pPrintPrec _ _ (Char c) = text $ show c
+
+instance Pretty Term where
+ pPrintPrec level prec (Term e) = pPrintPrec level prec e
+
+instance Pretty TaggedTerm where
+ pPrintPrec level prec (TaggedTerm e) = pPrintPrec level prec e
+
+instance Pretty term => Pretty (TermF term) where
+ pPrintPrec level prec e = case e of
+ LetRec xes e -> pPrintPrecLetRec level prec xes e
+ Var x -> pPrintPrec level prec x
+ Value v -> pPrintPrec level prec v
+ App e1 x2 -> pPrintPrecApp level prec e1 x2
+ PrimOp pop xs -> pPrintPrecPrimOp level prec pop xs
+ Case e alts | level == haskellLevel, null alts -> pPrintPrecSeq level prec e (text "undefined")
+ | level == haskellLevel, [(DefaultAlt Nothing, e_alt)] <- alts -> pPrintPrecSeq level prec e e_alt
+ | level == haskellLevel, [(DefaultAlt (Just x), e_alt)] <- alts -> pPrintPrecLetRec level prec [(x, e)] e_alt
+ | otherwise -> pPrintPrecCase level prec e alts
+
+pPrintPrecSeq :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> b -> Doc
+pPrintPrecSeq level prec e1 e2 = pPrintPrecApp level prec (PrettyFunction $ \level prec -> pPrintPrecApp level prec (name "seq") e1) e2
+
+pPrintPrecApp :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> b -> Doc
+pPrintPrecApp level prec e1 e2 = prettyParen (prec >= appPrec) $ pPrintPrec level opPrec e1 <+> pPrintPrec level appPrec e2
+
+pPrintPrecPrimOp :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> [b] -> Doc
+pPrintPrecPrimOp level prec pop xs = pPrintPrecApps level prec pop xs
+
+pPrintPrecCase :: (Pretty a, Pretty b, Pretty c) => PrettyLevel -> Rational -> a -> [(b, c)] -> Doc
+pPrintPrecCase level prec e alts = prettyParen (prec > noPrec) $ hang (text "case" <+> pPrintPrec level noPrec e <+> text "of") 2 $ vcat (map (pPrintPrecAlt level noPrec) alts)
+
+pPrintPrecAlt :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> (a, b) -> Doc
+pPrintPrecAlt level _ (alt_con, alt_e) = hang (pPrintPrec level noPrec alt_con <+> text "->") 2 (pPrintPrec level noPrec alt_e)
+
+pPrintPrecLetRec :: (Pretty a, Pretty b, Pretty c) => PrettyLevel -> Rational -> [(a, b)] -> c -> Doc
+pPrintPrecLetRec level prec xes e_body
+ | [] <- xes = pPrintPrec level prec e_body
+ | otherwise = prettyParen (prec > noPrec) $ hang (if level == haskellLevel then text "let" else text "letrec") 2 (vcat [pPrintPrec level noPrec x <+> text "=" <+> pPrintPrec level noPrec e | (x, e) <- xes]) $$ text "in" <+> pPrintPrec level noPrec e_body
+
+instance Pretty term => Pretty (ValueF term) where
+ pPrintPrec level prec v = case v of
+ -- Unfortunately, this nicer pretty-printing doesn't work for general (TermF term):
+ --Lambda x e -> pPrintPrecLam level prec (x:xs) e'
+ -- where (xs, e') = collectLambdas e
+ Lambda x e -> pPrintPrecLam level prec [x] e
+ Data dc xs -> pPrintPrecApps level prec (PrettyFunction $ \_ _ -> text dc) xs
+ Literal l -> pPrintPrec level prec l
+
+pPrintPrecLam :: Pretty a => PrettyLevel -> Rational -> [Var] -> a -> Doc
+pPrintPrecLam level prec xs e = prettyParen (prec > noPrec) $ text "\\" <> hsep [pPrintPrec level appPrec y | y <- xs] <+> text "->" <+> pPrintPrec level noPrec e
+
+pPrintPrecApps :: (Pretty a, Pretty b) => PrettyLevel -> Rational -> a -> [b] -> Doc
+pPrintPrecApps level prec e1 es2 = prettyParen (not (null es2) && prec >= appPrec) $ pPrintPrec level opPrec e1 <+> hsep (map (pPrintPrec level appPrec) es2)
+
+
+tagTerm :: IdSupply -> Term -> TaggedTerm
+tagTerm ids (Term e) = TaggedTerm $ Tagged (hashedId i) $ case e of
+ Var x -> Var x
+ Value v -> Value (tagValue ids' v)
+ App e x -> App (tagTerm ids' e) x
+ PrimOp pop es -> PrimOp pop (zipWith tagTerm idss' es)
+ Case e alts -> Case (tagTerm ids' e) (tagAlts (head idss') alts)
+ LetRec xes e -> LetRec (zipWith (\ids'' (x, e) -> (x, tagTerm ids'' e)) idss' xes) (tagTerm ids' e)
+ where
+ (ids', i) = stepIdSupply ids
+ idss' = splitIdSupplyL ids'
+
+tagValue :: IdSupply -> Value -> TaggedValue
+tagValue ids v = case v of
+ Lambda x e -> Lambda x (tagTerm ids e)
+ Data dc xs -> Data dc xs
+ Literal l -> Literal l
+
+tagAlt :: IdSupply -> Alt -> TaggedAlt
+tagAlt ids (con, e) = (con, tagTerm ids e)
+
+tagAlts :: IdSupply -> [Alt] -> [TaggedAlt]
+tagAlts = zipWith tagAlt . splitIdSupplyL
+
+detagTerm :: TaggedTerm -> Term
+detagTerm (TaggedTerm (Tagged _ e)) = case e of
+ Var x -> var x
+ Value v -> value (detagValue v)
+ App e x -> app (detagTerm e) x
+ PrimOp pop es -> primOp pop (map detagTerm es)
+ Case e alts -> case_ (detagTerm e) (detagAlts alts)
+ LetRec xes e -> letRec (map (second detagTerm) xes) (detagTerm e)
+
+detagValue :: TaggedValue -> Value
+detagValue (Lambda x e) = Lambda x (detagTerm e)
+detagValue (Data dc xs) = Data dc xs
+detagValue (Literal l) = Literal l
+
+detagAlts :: [TaggedAlt] -> [Alt]
+detagAlts = map (second detagTerm)
+
+
+isValue :: TermF term -> Bool
+isValue (Value _) = True
+isValue _ = False
+
+termIsValue :: Term -> Bool
+termIsValue = isValue . unTerm
+
+isCheap :: TermF term -> Bool
+isCheap (Var _) = True
+isCheap (Value _) = True
+isCheap _ = False
+
+termIsCheap :: Term -> Bool
+termIsCheap = isCheap . unTerm
+
+taggedTermIsCheap :: TaggedTerm -> Bool
+taggedTermIsCheap = isCheap . tagee . unTaggedTerm
+
+letRec :: [(Var, Term)] -> Term -> Term
+letRec [] e = e
+letRec xes e = Term $ LetRec xes e
+
+var :: Var -> Term
+var = Term . Var
+
+value :: Value -> Term
+value = Term . Value
+
+literal :: Literal -> Term
+literal = value . Literal
+
+lambda :: Var -> Term -> Term
+lambda x = value . Lambda x
+
+lambdas :: [Var] -> Term -> Term
+lambdas = flip $ foldr lambda
+
+data_ :: DataCon -> [Var] -> Term
+data_ dc = value . Data dc
+
+primOp :: PrimOp -> [Term] -> Term
+primOp pop es = Term (PrimOp pop es)
+
+app :: Term -> Var -> Term
+app e x = Term (App e x)
+
+apps :: Term -> [Var] -> Term
+apps = foldl app
+
+varApps :: Var -> [Var] -> Term
+varApps h xs = var h `apps` xs
+
+case_ :: Term -> [Alt] -> Term
+case_ e = Term . Case e
+
+collectLambdas :: Term -> ([Var], Term)
+collectLambdas (Term (Value (Lambda x e))) = first (x:) $ collectLambdas e
+collectLambdas e = ([], e)
+
+freshFloatVar :: IdSupply -> String -> Term -> (IdSupply, Maybe (Name, Term), Name)
+freshFloatVar ids _ (Term (Var x)) = (ids, Nothing, x)
+freshFloatVar ids s e = (ids', Just (y, e), y)
+ where (ids', y) = freshName ids s
+
+freshFloatVars :: IdSupply -> String -> [Term] -> (IdSupply, [(Name, Term)], [Name])
+freshFloatVars ids s es = reassociate $ mapAccumL (\ids -> associate . freshFloatVar ids s) ids es
+ where reassociate (ids, unzip -> (mb_floats, xs)) = (ids, catMaybes mb_floats, xs)
+ associate (ids, mb_float, x) = (ids, (mb_float, x))
65 Evaluator/Evaluate.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE ViewPatterns, TupleSections, PatternGuards #-}
+module Evaluator.Evaluate (step) where
+
+import Evaluator.Syntax
+
+import Core.Renaming
+import Core.Syntax
+import Core.Prelude (trueDataCon, falseDataCon)
+
+import Renaming
+import Utilities
+
+import qualified Data.Map as M
+
+
+step :: State -> Maybe State
+step (h, k, (rn, TaggedTerm (Tagged tg e))) = case e of
+ Var x -> force h k tg (rename rn x)
+ Value v -> unwind h k (rn, v)
+ App e1 x2 -> Just (h, Tagged tg (Apply (rename rn x2)) : k, (rn, e1))
+ PrimOp pop (e:es) -> Just (h, Tagged tg (PrimApply pop [] (map (rn,) es)) : k, (rn, e))
+ Case e alts -> Just (h, Tagged tg (Scrutinise (rn, alts)) : k, (rn, e))
+ LetRec xes e -> Just (allocate h k (rn, (xes, e)))
+
+force :: Heap -> Stack -> Tag -> Out Var -> Maybe State
+force (Heap h ids) k tg x' = M.lookup x' h >>= \in_e -> return (Heap (M.delete x' h) ids, Tagged tg (Update x') : k, in_e)
+
+unwind :: Heap -> Stack -> In TaggedValue -> Maybe State
+unwind h k in_v = uncons k >>= \(Tagged tg kf, k) -> return $ case kf of
+ Apply x2' -> apply h k in_v x2'
+ Scrutinise in_alts -> scrutinise h k tg in_v in_alts
+ PrimApply pop in_vs in_es -> primop h k tg pop in_vs in_v in_es
+ Update x' -> update h k tg x' in_v
+
+apply :: Heap -> Stack -> In TaggedValue -> Out Var -> State
+apply h k (rn, Lambda x e_body) x2' = (h, k, (insertRenaming x x2' rn, e_body))
+apply _ _ (_, v) _ = panic "apply" (pPrint v)
+
+scrutinise :: Heap -> Stack -> Tag -> In TaggedValue -> In [TaggedAlt] -> State
+scrutinise h k _ (_, Literal l) (rn_alts, alts)
+ | alt_e:_ <- [(rn_alts, alt_e) | (LiteralAlt alt_l, alt_e) <- alts, alt_l == l] ++ [(rn_alts, alt_e) | (DefaultAlt Nothing, alt_e) <- alts] = (h, k, alt_e)
+scrutinise h k _ (rn_v, Data dc xs) (rn_alts, alts)
+ | alt_e:_ <- [(insertRenamings (alt_xs `zip` map (rename rn_v) xs) rn_alts, alt_e) | (DataAlt alt_dc alt_xs, alt_e) <- alts, alt_dc == dc] ++ [(rn_alts, alt_e) | (DefaultAlt Nothing, alt_e) <- alts] = (h, k, alt_e)
+scrutinise (Heap h ids) k tg (rn_v, v) (rn_alts, alts)
+ | (alt_x, alt_e):_ <- [(alt_x, alt_e) | (DefaultAlt (Just alt_x), alt_e) <- alts]
+ , (ids', rn_alts', alt_x') <- renameBinder ids rn_alts alt_x
+ = (Heap (M.insert alt_x' (rn_v, TaggedTerm $ Tagged tg $ Value v) h) ids', k, (rn_alts', alt_e))
+ | otherwise
+ = panic "scrutinise" (pPrint v)
+
+primop :: Heap -> Stack -> Tag -> PrimOp -> [In TaggedValue] -> In TaggedValue -> [In TaggedTerm] -> State
+primop h k tg pop [(_, Literal (Int l1))] (_, Literal (Int l2)) [] = (h, k, (emptyRenaming, TaggedTerm $ Tagged tg (Value (f pop l1 l2))))
+ where f pop = case pop of Add -> retInt (+); Subtract -> retInt (-);
+ Multiply -> retInt (*); Divide -> retInt div; Modulo -> retInt mod;
+ Equal -> retBool (==); LessThanEqual -> retBool (<=)
+ retInt pop l1 l2 = Literal (Int (pop l1 l2))
+ retBool pop l1 l2 = if pop l1 l2 then Data trueDataCon [] else Data falseDataCon []
+primop h k tg pop in_vs (rn, v) (in_e:in_es) = (h, Tagged tg (PrimApply pop (in_vs ++ [(rn, v)]) in_es) : k, in_e)
+
+update :: Heap -> Stack -> Tag -> Out Var -> In TaggedValue -> State
+update (Heap h ids) k tg x' (rn, v) = (Heap (M.insert x' (rn, TaggedTerm $ Tagged tg (Value v)) h) ids, k, (rn, TaggedTerm $ Tagged tg (Value v)))
+
+allocate :: Heap -> Stack -> In ([(Var, TaggedTerm)], TaggedTerm) -> State
+allocate (Heap h ids) k (rn, (xes, e)) = (Heap (h `M.union` M.fromList xes') ids', k, (rn', e))
+ where (ids', rn', xes') = renameBounds (\_ x' -> x') ids rn xes
48 Evaluator/FreeVars.hs
@@ -0,0 +1,48 @@
+module Evaluator.FreeVars (
+ renamingFreeVars,
+ inFreeVars,
+ pureHeapFreeVars, pureHeapOpenFreeVars,
+ stackFreeVars, stackFrameFreeVars,
+ stateFreeVars, pureStateFreeVars
+ ) where
+
+import Evaluator.Syntax
+
+import Core.FreeVars
+import Core.Renaming
+
+import Renaming
+import Utilities
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+
+renamingFreeVars :: Renaming -> FreeVars -> FreeVars
+renamingFreeVars rn fvs = S.map (rename rn) fvs
+
+inFreeVars :: (a -> FreeVars) -> In a -> FreeVars
+inFreeVars thing_fvs (rn, thing) = renamingFreeVars rn (thing_fvs thing)
+
+pureHeapFreeVars :: PureHeap -> (BoundVars, FreeVars) -> FreeVars
+pureHeapFreeVars h (bvs, fvs) = fvs' S.\\ bvs'
+ where (bvs', fvs') = pureHeapOpenFreeVars h (bvs, fvs)
+
+pureHeapOpenFreeVars :: PureHeap -> (BoundVars, FreeVars) -> (BoundVars, FreeVars)
+pureHeapOpenFreeVars = flip $ M.foldWithKey (\x' in_e (bvs, fvs) -> (S.insert x' bvs, fvs `S.union` inFreeVars taggedTermFreeVars in_e))
+
+stackFreeVars :: Stack -> FreeVars -> (BoundVars, FreeVars)
+stackFreeVars k fvs = (S.unions *** (S.union fvs . S.unions)) . unzip . map (stackFrameFreeVars . tagee) $ k
+
+stackFrameFreeVars :: StackFrame -> (BoundVars, FreeVars)
+stackFrameFreeVars kf = case kf of
+ Apply x' -> (S.empty, S.singleton x')
+ Scrutinise in_alts -> (S.empty, inFreeVars taggedAltsFreeVars in_alts)
+ PrimApply _ in_vs in_es -> (S.empty, S.unions (map (inFreeVars taggedValueFreeVars) in_vs) `S.union` S.unions (map (inFreeVars taggedTermFreeVars) in_es))
+ Update x' -> (S.singleton x', S.empty)
+
+stateFreeVars :: State -> FreeVars
+stateFreeVars (Heap h _, k, in_e) = pureStateFreeVars (h, k, in_e)
+
+pureStateFreeVars :: PureState -> FreeVars
+pureStateFreeVars (h, k, in_e) = pureHeapFreeVars h (stackFreeVars k (inFreeVars taggedTermFreeVars in_e))
23 Evaluator/Syntax.hs
@@ -0,0 +1,23 @@
+module Evaluator.Syntax where
+
+import Core.Renaming
+import Core.Syntax
+
+import Utilities
+
+import qualified Data.Map as M
+
+
+type PureState = (PureHeap, Stack, In TaggedTerm)
+type State = (Heap, Stack, In TaggedTerm)
+
+type PureHeap = M.Map (Out Var) (In TaggedTerm)
+data Heap = Heap PureHeap IdSupply
+ deriving (Show)
+
+type Stack = [Tagged StackFrame]
+data StackFrame = Apply (Out Var)
+ | Scrutinise (In [TaggedAlt])
+ | PrimApply PrimOp [In TaggedValue] [In TaggedTerm]
+ | Update (Out Var)
+ deriving (Show)
117 GHC.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE ViewPatterns #-}
+module GHC where
+
+import Core.Syntax
+
+import Utilities
+import StaticFlags
+
+import Control.Exception
+
+import System.Directory
+import System.Exit
+import System.IO
+import System.Process
+
+
+termToHaskell :: Term -> String
+termToHaskell = show . pPrintPrec haskellLevel 0
+
+termToHaskellBinding :: String -> Term -> [String]
+termToHaskellBinding name e = (name ++ " = " ++ l) : map (replicate indent ' ' ++) ls
+ where indent = length name + 3
+ (l:ls) = lines $ termToHaskell e
+
+languageLine :: String
+languageLine = "{-# LANGUAGE ExtendedDefaultRules, NoMonoPatBinds #-}"
+
+testingModule :: String -> Term -> Term -> String
+testingModule wrapper e test_e = unlines $
+ languageLine :
+ "module Main(main) where" :
+ "import Control.DeepSeq" :
+ "import Data.Time.Clock.POSIX (getPOSIXTime)" :
+ [wrapper] ++
+ "" :
+ "time_ :: IO a -> IO Double" :
+ "time_ act = do { start <- getTime; act; end <- getTime; return $! (Prelude.-) end start }" :
+ "" :
+ "getTime :: IO Double" :
+ "getTime = (fromRational . toRational) `fmap` getPOSIXTime" :
+ "" :
+ "main = do { t <- time_ (rnf results `seq` return ()); print t }" :
+ " where results = map assertEq tests" :
+ "" :
+ "assertEq :: (Show a, Eq a) => (a, a) -> ()" :
+ "assertEq (x, y) = if x == y then () else error (\"FAIL! \" ++ show x ++ \", \" ++ show y)" :
+ "" :
+ termToHaskellBinding "root" e ++
+ termToHaskellBinding "tests" test_e
+
+printingModule :: String -> Term -> String
+printingModule wrapper e = unlines $
+ languageLine :
+ "module Main(main, root) where" :
+ "import Text.Show.Functions" :
+ [wrapper] ++
+ "" :
+ "main = print root" :
+ "" :
+ termToHaskellBinding "root" e
+
+
+
+typechecks :: String -> Term -> IO Bool
+typechecks wrapper term = do
+ (ec, _out, err) <- withTempFile "Main.hs" $ \(file, h) -> do
+ hPutStr h haskell
+ hClose h
+ readProcessWithExitCode "ghc" ["-c", file, "-fforce-recomp"] ""
+ case ec of
+ ExitSuccess -> return True
+ _ -> do
+ putStrLn err
+ return False
+ where
+ haskell = printingModule wrapper term
+
+normalise :: String -> Term -> IO (Either String String)
+normalise wrapper term = do
+ let haskell = printingModule wrapper term
+ (ec, out, err) <- withTempFile "Main.hs" $ \(file, h) -> do
+ hPutStr h haskell
+ hClose h
+ readProcessWithExitCode "ghc" ["--make", "-O2", file, "-ddump-simpl", "-fforce-recomp"] ""
+ case ec of
+ ExitSuccess -> return (Right out)
+ ExitFailure _ -> putStrLn haskell >> return (Left err)
+
+runCompiled :: String -> Term -> Term -> IO (String, Either String (Bytes, Seconds, Bytes, Seconds))
+runCompiled wrapper e test_e = withTempFile "Main" $ \(exe_file, exe_h) -> do
+ hClose exe_h
+ let haskell = testingModule wrapper e test_e
+ (compile_t, (ec, compile_out, compile_err)) <- withTempFile "Main.hs" $ \(hs_file, hs_h) -> do
+ hPutStr hs_h haskell
+ hClose hs_h
+ time $ readProcessWithExitCode "ghc" (["--make", "-O2", hs_file, "-fforce-recomp", "-o", exe_file] ++ ["-ddump-simpl" | not qUIET]) "" --
+ compiled_size <- fileSize exe_file
+ case ec of
+ ExitFailure _ -> putStrLn haskell >> return (haskell, Left compile_err)
+ ExitSuccess -> do
+ (ec, run_out, run_err) <- readProcessWithExitCode exe_file ["+RTS", "-t"] ""
+ case ec of
+ ExitFailure _ -> putStrLn haskell >> return (haskell, Left (unlines [compile_out, run_err]))
+ ExitSuccess -> do
+ -- <<ghc: 7989172 bytes, 16 GCs, 20876/20876 avg/max bytes residency (1 samples), 1M in use, 0.00 INIT (0.00 elapsed), 0.02 MUT (0.51 elapsed), 0.00 GC (0.00 elapsed) :ghc>>
+ let [t_str] = lines run_out
+ [gc_stats] = (filter ("<<ghc" `isPrefixOf`) . lines) run_err
+ total_bytes_allocated = read (words gc_stats !! 1)
+ return (haskell, Right (compiled_size, compile_t, total_bytes_allocated, read t_str))
+
+withTempFile :: String -> ((FilePath, Handle) -> IO b) -> IO b
+withTempFile name action = do
+ tmpdir <- getTemporaryDirectory
+ bracket
+ (openTempFile tmpdir name)
+ (\(fp,h) -> hClose h >> removeFile fp)
+ action
95 IdSupply.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE MagicHash #-}
+
+-- | This module provides splittable supplies for unique identifiers.
+-- The main idea gows back to L. Augustsson, M. Rittri, and D. Synek
+-- and is described in their paper 'On generating unique names'
+-- (Journal of Functional Programming 4(1), 1994. pp. 117-123). The
+-- implementation at hand is taken from the GHC sources and includes
+-- bit fiddling to allow multiple supplies that generate unique
+-- identifiers by prepending a character given at initialization.
+--
+-- This is a custom version of uniqueid-0.1.1 to resolve some bugs I
+-- found in it.
+module IdSupply (
+ Id, hashedId, IdSupply, initIdSupply, splitIdSupplyL, splitIdSupply, idFromSupply
+ ) where
+
+import GHC.Exts
+-- MCB: change to uniqueid-0.1.1: use GHC.IO rather than GHC.IOBase
+import GHC.IO ( unsafeDupableInterleaveIO )
+
+import Data.IORef
+import System.IO.Unsafe ( unsafePerformIO )
+
+
+-- | Unique identifiers are of type 'Id' and can be hashed to an 'Int'
+-- usning the function 'hashedId'.
+newtype Id = Id { hashedId :: Int }
+
+-- | Supplies for unique identifiers are of type 'IdSupply' and can be
+-- split into two new supplies or yield a unique identifier.
+data IdSupply = IdSupply Int# IdSupply IdSupply
+
+-- | Generates a new supply of unique identifiers. The given character
+-- is prepended to generated numbers.
+initIdSupply :: Char -> IO IdSupply
+initIdSupply (C# c) =
+ case uncheckedIShiftL# (ord# c) (unboxedInt 24) of
+ mask ->
+ let mkSupply =
+ unsafeDupableInterleaveIO (
+ nextInt >>= \ (I# u) ->
+ mkSupply >>= \ l ->
+ mkSupply >>= \ r ->
+ return (IdSupply (word2Int# (or# (int2Word# mask) (int2Word# u))) l r))
+ in mkSupply
+
+-- | Splits a supply of unique identifiers to yield two of them.
+splitIdSupply :: IdSupply -> (IdSupply,IdSupply)
+splitIdSupply (IdSupply _ l r) = (l,r)
+
+-- | Splits a supply of unique identifiers to yield an infinite list of them.
+splitIdSupplyL :: IdSupply -> [IdSupply]
+splitIdSupplyL ids = ids1 : splitIdSupplyL ids2
+ where
+ (ids1, ids2) = splitIdSupply ids
+
+-- | Yields the unique identifier from a supply.
+idFromSupply :: IdSupply -> Id
+idFromSupply (IdSupply n _ _) = Id (I# n)
+
+instance Eq Id where Id (I# x) == Id (I# y) = x ==# y
+
+instance Ord Id
+ where
+ Id (I# x) < Id (I# y) = x <# y
+ Id (I# x) <= Id (I# y) = x <=# y
+
+ compare (Id (I# x)) (Id (I# y)) =
+ if x ==# y then EQ else if x <# y then LT else GT
+
+instance Show Id
+ where
+ showsPrec _ i s = case unpackId i of (c,n) -> c:show n++s
+
+
+
+
+unboxedInt :: Int -> Int#
+unboxedInt (I# x) = x
+
+-- MCB: change to uniqueid-0.1.1: ensure that the global IORef is not inlined!
+{-# NOINLINE global #-}
+global :: IORef Int
+global = unsafePerformIO (newIORef 0)
+
+-- MCB: change to uniqueid-0.1.1: prevent race conditions
+nextInt :: IO Int
+nextInt = atomicModifyIORef global (\n -> (succ n, succ n))
+
+unpackId :: Id -> (Char,Int)
+unpackId (Id (I# i)) =
+ let tag = C# (chr# (uncheckedIShiftRL# i (unboxedInt 24)))
+ num = I# (word2Int# (and# (int2Word# i)
+ (int2Word# (unboxedInt 16777215))))
+ in (tag, num)
30 LICENSE
@@ -0,0 +1,30 @@
+Copyright Max Bolingbroke 2009-2010.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Max Bolingbroke nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
88 Main.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE ViewPatterns #-}
+module Main (main) where
+
+import Core.FreeVars
+import Core.Syntax
+import Core.Parser
+
+import Supercompile.Drive
+
+import GHC
+import Name
+import Utilities
+import StaticFlags
+
+import Data.Char (toLower)
+import qualified Data.Set as S
+
+import System.Directory
+import System.Environment
+import System.Exit
+import System.FilePath ((</>), dropExtension, takeFileName, takeDirectory, replaceExtension)
+import System.IO
+
+import Numeric (showFFloat)
+
+
+main :: IO ()
+main = do
+ (_flags, args) <- fmap (partition ("-" `isPrefixOf`)) getArgs
+ mapM_ testOne args
+
+
+splitModule :: [(Var, Term)] -> (Term, Maybe Term)
+splitModule xes = (letRec (transitiveInline (S.singleton root)) (var root),
+ fmap (\test -> letRec (filter ((/= root) . fst) $ transitiveInline (S.singleton test)) (var test)) mb_test)
+ where
+ findBinding what = fmap fst $ find ((== what) . name_string . fst) xes
+
+ transitiveInline fvs
+ | fvs == fvs' = need_xes
+ | otherwise = transitiveInline fvs'
+ where
+ need_xes = [(x, e) | (x, e) <- xes, x `S.member` fvs]
+ fvs' = fvs `S.union` S.unions (map (termFreeVars . snd) need_xes)
+
+ root = expectJust "No root" $ findBinding "root"
+ mb_test = findBinding "tests"
+
+
+testOne :: FilePath -> IO ()
+testOne file = do
+ hPutStrLn stderr file
+ (wrapper, binds) <- parse file
+ case splitModule binds of
+ (_, Nothing) -> hPutStrLn stderr "Skipping: no tests"
+ (e, Just test_e) -> do
+ (before_code, before_res) <- runCompiled wrapper e test_e
+
+ -- Save a copy of the non-supercompiled code
+ createDirectoryIfMissing True (takeDirectory $ "input" </> file)
+ writeFile ("input" </> replaceExtension file ".hs") before_code
+
+ (_before_size, before_compile_t, before_heap_size, before_run_t) <- catchLeft before_res
+
+ rnf e `seq` return ()
+ let e' = supercompile e
+ super_t <- time_ (rnf e' `seq` return ())
+
+ (after_code, after_res) <- runCompiled wrapper e' test_e
+
+ -- Save a copy of the supercompiled code somewhere so I can consult it at my leisure
+ let output_dir = foldl1 (</>) [ "output"
+ , if eVALUATE_PRIMOPS then "primops" else "no-primops"
+ ]
+ createDirectoryIfMissing True (takeDirectory $ output_dir </> file)
+ writeFile (output_dir </> replaceExtension file ".hs") after_code
+
+ (_after_size, after_compile_t, after_heap_size, after_run_t) <- catchLeft after_res
+
+ let dp1 x = showFFloat (Just 1) x ""
+ dp2 x = showFFloat (Just 2) x ""
+ ratio n m = fromIntegral n / fromIntegral m :: Double
+ escape = concatMap (\c -> if c == '_' then "\\_" else [c])
+ putStrLn $ intercalate " & " [escape $ map toLower $ takeFileName $ dropExtension file, dp1 super_t ++ "s", dp2 (after_compile_t / before_compile_t), dp2 (after_run_t / before_run_t), dp2 (after_heap_size `ratio` before_heap_size)] ++ " \\\\"
+
+catchLeft :: Either String b -> IO b
+catchLeft (Left err) = hPutStrLn stderr err >> exitWith (ExitFailure 1)
+catchLeft (Right res) = return res
49 Name.hs
@@ -0,0 +1,49 @@
+module Name (
+ Name(..), name,
+ freshName, freshNames
+ ) where
+
+import Utilities
+
+import Data.Char
+import Data.Function
+import Data.Ord
+
+
+data Name = Name {
+ name_string :: String,
+ name_id :: Maybe Id
+ }
+
+instance NFData Name where
+ rnf (Name a b) = rnf a `seq` rnf b
+
+instance Show Name where
+ show n = "(name " ++ show (show (pPrint n)) ++ ")"
+
+instance Eq Name where
+ (==) = (==) `on` name_key
+
+instance Ord Name where
+ compare = comparing name_key
+
+instance Pretty Name where
+ pPrintPrec level _ n = text (escape $ name_string n) <> maybe empty (\i -> text "_" <> text (show i)) (name_id n)
+ where escape | level == haskellLevel = concatMap escapeHaskellChar
+ | otherwise = id
+ escapeHaskellChar c
+ | c == 'z' = "zz"
+ | isAlphaNum c || c `elem` ['_', '\''] = [c]
+ | otherwise = 'z' : show (ord c)
+
+name_key :: Name -> Either String Id
+name_key n = maybe (Left $ name_string n) Right (name_id n)
+
+name :: String -> Name
+name s = Name s Nothing
+
+freshName :: IdSupply -> String -> (IdSupply, Name)
+freshName ids s = second (Name s . Just) $ stepIdSupply ids
+
+freshNames :: IdSupply -> [String] -> (IdSupply, [Name])
+freshNames = mapAccumL freshName
79 Renaming.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE PatternGuards #-}
+module Renaming (
+ Renaming(..),
+ emptyRenaming, mkRenaming, mkIdentityRenaming,
+ insertRenaming, insertRenamings,
+ rename, rename_maybe, safeRename, unrename,
+ renameBinder, renameBinders,
+ renameRenaming,
+ foldRenaming
+ ) where
+
+import Name
+import Utilities
+
+import qualified Data.Map as M
+
+
+type In a = a
+type Out a = a
+
+
+newtype Renaming = Renaming { unRenaming :: M.Map (In Name) (Out Name) }
+ deriving (Show)
+
+instance Pretty Renaming where
+ pPrintPrec level _ rn = vcat [ pPrintPrec level 0 x <+> text "|->" <+> pPrintPrec level 0 x'
+ | (x, x') <- M.toList (unRenaming rn)]
+
+
+emptyRenaming :: Renaming
+emptyRenaming = Renaming M.empty
+
+mkRenaming :: [(Name, Name)] -> Renaming
+mkRenaming = Renaming . M.fromList
+
+mkIdentityRenaming :: [Name] -> Renaming
+mkIdentityRenaming = mkRenaming . map (id &&& id)
+
+insertRenaming :: In Name -> Out Name -> Renaming -> Renaming
+insertRenaming n n' = Renaming . M.insert n n' . unRenaming
+
+insertRenamings :: [(In Name, Out Name)] -> Renaming -> Renaming
+insertRenamings = flip $ foldr (uncurry insertRenaming)
+
+rename :: Renaming -> In Name -> Out Name
+rename = safeRename' Nothing
+
+safeRename :: String -> Renaming -> In Name -> Out Name
+safeRename = safeRename' . Just
+
+safeRename' :: Maybe String -> Renaming -> In Name -> Out Name
+safeRename' mb_stk rn n | Just n' <- rename_maybe rn n = n'
+ | otherwise = error $ show (text "Name" <+> pPrint n <+> text "out of scope" <+> maybe empty (\stk -> text "in" <+> text stk) mb_stk <> text "! Renaming:" $$ pPrint rn)
+
+rename_maybe :: Renaming -> In Name -> Maybe (Out Name)
+rename_maybe rn n = M.lookup n (unRenaming rn)
+
+unrename :: Renaming -> Out Name -> [In Name]
+unrename rn n' = [m | (m, m') <- M.toList (unRenaming rn), m' == n']
+
+renameBinder :: IdSupply -> Renaming -> In Name -> (IdSupply, Renaming, Out Name)
+renameBinder ids rn n = (ids', insertRenaming n n' rn, n')
+ where (ids', n') = freshName ids (name_string n)
+
+renameBinders :: IdSupply -> Renaming -> [In Name] -> (IdSupply, Renaming, [Out Name])
+renameBinders ids rn = reassociate . mapAccumL ((associate .) . uncurry renameBinder) (ids, rn)
+ where associate (ids, rn, n) = ((ids, rn), n)
+ reassociate ((ids, rn), ns) = (ids, rn, ns)
+
+-- NB: throws away something from the Renaming being renamed if it is not in the domain of rn_by.
+-- This is useful behaviour for the term normalisation logic in the supercompiler, because the
+-- "normalising" renaming will only contain entries for actual free variables, but the "internal"
+-- renamings (e.g. those in the Heaps' In Terms') may contain many more entries.
+renameRenaming :: Renaming -> Renaming -> Renaming
+renameRenaming rn_by = Renaming . M.mapMaybe (rename_maybe rn_by) . unRenaming
+
+foldRenaming :: (In Name -> Out Name -> b -> b) -> b -> Renaming -> b
+foldRenaming f b = M.foldWithKey f b . unRenaming
+
3 Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
21 StaticFlags.hs
@@ -0,0 +1,21 @@
+module StaticFlags where
+
+import System.Environment
+import System.IO.Unsafe
+
+
+{-# NOINLINE aSSERTIONS #-}
+aSSERTIONS :: Bool
+aSSERTIONS = not $ "--no-assertions" `elem` (unsafePerformIO getArgs)
+
+{-# NOINLINE qUIET #-}
+qUIET :: Bool
+qUIET = "-v0" `elem` (unsafePerformIO getArgs)
+
+{-# NOINLINE tERMINATION_CHECK #-}
+tERMINATION_CHECK :: Bool
+tERMINATION_CHECK = not $ "--no-termination" `elem` (unsafePerformIO getArgs)
+
+{-# NOINLINE eVALUATE_PRIMOPS #-}
+eVALUATE_PRIMOPS :: Bool
+eVALUATE_PRIMOPS = not $ "--no-primops" `elem` (unsafePerformIO getArgs)
174 Supercompile/Drive.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE ViewPatterns, TupleSections, PatternGuards, BangPatterns #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module Supercompile.Drive (supercompile) where
+
+import Supercompile.Match
+import Supercompile.Residualise
+import Supercompile.Split
+
+import Core.FreeVars
+import Core.Renaming
+import Core.Syntax
+
+import Evaluator.Evaluate
+import Evaluator.FreeVars
+import Evaluator.Syntax
+
+import Termination.Terminate
+
+import Name
+import Renaming
+import StaticFlags
+import Utilities
+
+import qualified Data.Map as M
+import Data.Ord
+import qualified Data.Set as S
+
+
+supercompile :: Term -> Term
+supercompile e = traceRender ("all input FVs", fvs) $ runScpM fvs $ fmap snd $ sc [] state
+ where fvs = termFreeVars e
+ state = (Heap M.empty reduceIdSupply, [], (mkIdentityRenaming $ S.toList fvs, tagTerm tagIdSupply e))
+
+
+--
+-- == Termination ==
+--
+
+-- Other functions:
+-- Termination.Terminate.terminate
+
+-- This family of functions is the whole reason that I have to thread Tag information throughout the rest of the code:
+
+stateTagBag :: State -> TagBag
+stateTagBag (Heap h _, k, (_, e)) = pureHeapTagBag h `plusTagBag` stackTagBag k `plusTagBag` taggedTermTagBag e
+
+pureHeapTagBag :: PureHeap -> TagBag
+pureHeapTagBag = plusTagBags . map (taggedTagBag 5 . unTaggedTerm . snd) . M.elems
+
+stackTagBag :: Stack -> TagBag
+stackTagBag = plusTagBags . map (taggedTagBag 3)
+
+taggedTermTagBag :: TaggedTerm -> TagBag
+taggedTermTagBag = taggedTagBag 2 . unTaggedTerm
+
+taggedTagBag :: Int -> Tagged a -> TagBag
+taggedTagBag cls = tagTagBag cls . tag
+
+tagTagBag :: Int -> Tag -> TagBag
+tagTagBag cls = mkTagBag . return . injectTag cls
+
+
+--
+-- == The drive loop ==
+--
+
+reduce :: State -> State
+reduce = go emptyHistory
+ where
+ go hist state
+ | not eVALUATE_PRIMOPS, (_, _, (_, TaggedTerm (Tagged _ (PrimOp _ _)))) <- state = state
+ | otherwise = case step state of
+ Nothing -> state
+ Just state'
+ | intermediate state' -> go hist state'
+ | otherwise -> case terminate hist (stateTagBag state') of
+ Stop -> state'
+ Continue hist' -> go hist' state'
+
+ intermediate :: State -> Bool
+ intermediate (_, _, (_, TaggedTerm (Tagged _ (Var _)))) = False
+ intermediate _ = True
+
+
+data Promise = P {
+ fun :: Var, -- Name assigned in output program
+ fvs :: [Out Var], -- Abstracted over these variables
+ meaning :: State -- Minimum adequate term
+ }
+
+data ScpState = ScpState {
+ inputFvs :: FreeVars, -- NB: we do not abstract the h functions over these variables. This helps typechecking and gives GHC a chance to inline the definitions.
+ promises :: [Promise],
+ outs :: [(Var, Out Term)],
+ names :: [Var]
+ }
+
+get :: ScpM ScpState
+get = ScpM $ \s -> (s, s)
+
+put :: ScpState -> ScpM ()
+put s = ScpM $ \_ -> (s, ())
+
+modify :: (ScpState -> ScpState) -> ScpM ()
+modify f = fmap f get >>= put
+
+freshHName :: ScpM Var
+freshHName = ScpM $ \s -> (s { names = tail (names s) }, expectHead "freshHName" (names s))
+
+
+newtype ScpM a = ScpM { unScpM :: ScpState -> (ScpState, a) }
+
+instance Functor ScpM where
+ fmap = liftM
+
+instance Monad ScpM where
+ return x = ScpM $ \s -> (s, x)
+ (!mx) >>= fxmy = ScpM $ \s -> case unScpM mx s of (s, x) -> unScpM (fxmy x) s
+
+runScpM :: FreeVars -> ScpM (Out Term) -> Out Term
+runScpM input_fvs (ScpM f) = letRec (sortBy (comparing ((read :: String -> Int) . drop 1 . name_string . fst)) $ outs s) e'
+ where (s, e') = f init_s
+ init_s = ScpState { promises = [], names = map (\i -> name $ "h" ++ show (i :: Int)) [0..], outs = [], inputFvs = input_fvs }
+
+
+sc, sc' :: History -> State -> ScpM (FreeVars, Out Term)
+sc hist = memo (sc' hist)
+sc' hist state = case terminate hist (stateTagBag state) of
+ Stop -> split (sc hist) state
+ Continue hist' -> split (sc hist') (reduce state)
+
+
+memo :: (State -> ScpM (FreeVars, Out Term))
+ -> State -> ScpM (FreeVars, Out Term)
+memo opt state = traceRenderM (">sc", residualiseState state) >>
+ do
+ (ps, input_fvs) <- fmap (promises &&& inputFvs) get
+ case [ (S.fromList (rn_fvs (fvs p)), fun p `varApps` rn_fvs tb_noninput_fvs)
+ | p <- ps
+ , Just rn_lr <- [match (meaning p) state]
+ , let rn_fvs = map (safeRename ("tieback: FVs " ++ pPrintRender (fun p)) rn_lr) -- NB: If tb contains a dead PureHeap binding (hopefully impossible) then it may have a free variable that I can't rename, so "rename" will cause an error. Not observed in practice yet.
+ (tb_input_fvs, tb_noninput_fvs) = partition (`S.member` input_fvs) (fvs p)
+ -- Because we don't abstract over top-level free variables (this is necessary for type checking e.g. polymorphic uses of error):
+ , all (\x -> rename rn_lr x == x) tb_input_fvs
+ ] of
+ res:_ -> {- traceRender ("tieback", residualiseState state, fst res) $ -} do
+ traceRenderM ("<sc", residualiseState state, res)
+ return res
+ [] -> {- traceRender ("new drive", residualiseState state) $ -} do
+ x <- freshHName
+ let vs = stateFreeVars state
+ vs_list = S.toList vs
+ noninput_vs_list = filter (`S.notMember` input_fvs) vs_list
+ traceRenderM ("memo", x, vs_list) `seq` return ()
+
+ promise P { fun = x, fvs = vs_list, meaning = state }
+ (_fvs', e') <- opt state
+ assertRender ("sc: FVs", _fvs', vs) (_fvs' `S.isSubsetOf` vs) $ return ()
+
+ traceRenderM ("<sc", residualiseState state, (S.fromList vs_list, e'))
+
+ bind x (lambdas noninput_vs_list e')
+ return (vs, x `varApps` noninput_vs_list)
+
+
+promise :: Promise -> ScpM ()
+promise p = modify (\s -> s { promises = p : promises s })
+
+bind :: Var -> Out Term -> ScpM ()
+bind x e = modify (\s -> s { outs = (x, e) : outs s })
+
+traceRenderM :: Pretty a => a -> ScpM ()
+--traceRenderM x mx = fmap length history >>= \indent -> traceRender (nest indent (pPrint x)) mx
+traceRenderM x = traceRender (pPrint x) (return ())
165 Supercompile/Match.hs
@@ -0,0 +1,165 @@
+{-# LANGUAGE TupleSections, PatternGuards #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module Supercompile.Match (match) where
+
+import Core.Renaming
+import Core.Syntax
+
+import Evaluator.Syntax
+
+import Renaming
+import Utilities
+
+import qualified Data.Map as M
+
+
+match :: State -- ^ Tieback semantics
+ -> State -- ^ This semantics
+ -> Maybe Renaming -- ^ Renaming from left to right
+match (Heap h_l _, k_l, in_e_l) (Heap h_r _, k_r, in_e_r) = -- (\res -> traceRender ("match", M.keysSet h_l, residualiseDriveState (Heap h_l prettyIdSupply, k_l, in_e_l), M.keysSet h_r, residualiseDriveState (Heap h_r prettyIdSupply, k_r, in_e_r), res) res) $
+ do
+ free_eqs1 <- matchInTerm matchIdSupply in_e_l in_e_r
+ (bound_eqs, free_eqs2) <- matchEC k_l k_r
+ matchHeapExact h_l h_r (bound_eqs, free_eqs1 ++ free_eqs2)
+
+matchInTerm :: IdSupply -> In TaggedTerm -> In TaggedTerm -> Maybe [(Var, Var)]
+matchInTerm ids (rn_l, TaggedTerm (Tagged _ e_l)) (rn_r, TaggedTerm (Tagged _ e_r)) = matchInTerm' ids (rn_l, e_l) (rn_r, e_r)
+
+matchInTerm' :: IdSupply -> In (TermF TaggedTerm) -> In (TermF TaggedTerm) -> Maybe [(Var, Var)]
+matchInTerm' _ (rn_l, Var x_l) (rn_r, Var x_r) = Just [matchInVar (rn_l, x_l) (rn_r, x_r)]
+matchInTerm' ids (rn_l, Value v_l) (rn_r, Value v_r) = matchInValue ids (rn_l, v_l) (rn_r, v_r)
+matchInTerm' ids (rn_l, App e_l x_l) (rn_r, App e_r x_r) = matchInTerm ids (rn_l, e_l) (rn_r, e_r) >>= \eqs -> return (matchInVar (rn_l, x_l) (rn_r, x_r) : eqs)
+matchInTerm' ids (rn_l, PrimOp pop_l es_l) (rn_r, PrimOp pop_r es_r) = guard (pop_l == pop_r) >> matchInList (matchInTerm ids) (rn_l, es_l) (rn_r, es_r)
+matchInTerm' ids (rn_l, Case e_l alts_l) (rn_r, Case e_r alts_r) = liftM2 (++) (matchInTerm ids (rn_l, e_l) (rn_r, e_r)) (matchInAlts ids (rn_l, alts_l) (rn_r, alts_r))
+matchInTerm' ids (rn_l, LetRec xes_l e_l) (rn_r, LetRec xes_r e_r) = matchInTerm ids'' (rn_l', e_l) (rn_r', e_r) >>= \eqs -> matchPureHeapExact ids'' [] eqs (M.fromList xes_l') (M.fromList xes_r')
+ where (ids', rn_l', xes_l') = renameBounds (\_ x' -> x') ids rn_l xes_l
+ (ids'', rn_r', xes_r') = renameBounds (\_ x' -> x') ids' rn_r xes_r
+matchInTerm' _ _ _ = Nothing
+
+matchInValue :: IdSupply -> In TaggedValue -> In TaggedValue -> Maybe [(Var, Var)]
+matchInValue ids (rn_l, Lambda x_l e_l) (rn_r, Lambda x_r e_r) = matchInTerm ids'' (rn_l', e_l) (rn_r', e_r) >>= \eqs -> matchRigidBinders [(x_l', x_r')] eqs
+ where (ids', rn_l', x_l') = renameBinder ids rn_l x_l
+ (ids'', rn_r', x_r') = renameBinder ids' rn_r x_r
+matchInValue _ (rn_l, Data dc_l xs_l) (rn_r, Data dc_r xs_r) = guard (dc_l == dc_r) >> matchInVars (rn_l, xs_l) (rn_r, xs_r)
+matchInValue _ (_, Literal l_l) (_, Literal l_r) = guard (l_l == l_r) >> return []
+matchInValue _ _ _ = Nothing
+
+matchInAlts :: IdSupply -> In [TaggedAlt] -> In [TaggedAlt] -> Maybe [(Var, Var)]
+matchInAlts ids (rn_l, alts_l) (rn_r, alts_r) = zipWithEqual (matchInAlt ids) (map (rn_l,) alts_l) (map (rn_r,) alts_r) >>= (fmap concat . sequence)
+
+matchInAlt :: IdSupply -> In TaggedAlt -> In TaggedAlt -> Maybe [(Var, Var)]
+matchInAlt ids (rn_l, (alt_con_l, alt_e_l)) (rn_r, (alt_con_r, alt_e_r)) = matchAltCon alt_con_l' alt_con_r' >>= \binders -> matchInTerm ids'' (rn_l', alt_e_l) (rn_r', alt_e_r) >>= \eqs -> matchRigidBinders binders eqs
+ where (ids', rn_l', alt_con_l') = renameAltCon ids rn_l alt_con_l
+ (ids'', rn_r', alt_con_r') = renameAltCon ids' rn_r alt_con_r
+
+matchAltCon :: AltCon -> AltCon -> Maybe [(Var, Var)]
+matchAltCon (DataAlt dc_l xs_l) (DataAlt dc_r xs_r) = guard (dc_l == dc_r) >> return (xs_l `zip` xs_r)
+matchAltCon (LiteralAlt l_l) (LiteralAlt l_r) = guard (l_l == l_r) >> return []
+matchAltCon (DefaultAlt mb_x_l) (DefaultAlt mb_x_r) = matchMaybe matchVar mb_x_l mb_x_r
+matchAltCon _ _ = Nothing
+
+matchVar :: Out Var -> Out Var -> (Var, Var)
+matchVar x_l' x_r' = (x_l', x_r')
+
+matchInVar :: In Var -> In Var -> (Var, Var)
+matchInVar (rn_l, x_l) (rn_r, x_r) = (safeRename "matchInVar: Left" rn_l x_l, safeRename "matchInVar: Right" rn_r x_r)
+
+matchInVars :: In [Var] -> In [Var] -> Maybe [(Var, Var)]
+matchInVars = matchInList (\x_l' x_r' -> return [matchInVar x_l' x_r'])
+
+matchInList :: (In a -> In a -> Maybe [(Var, Var)])
+ -> In [a] -> In [a] -> Maybe [(Var, Var)]
+matchInList match (rn_l, xs_l) (rn_r, xs_r) = fmap concat $ zipWithEqualM match (map (rn_l,) xs_l) (map (rn_r,) xs_r)
+
+matchList :: (a -> a -> Maybe [(Var, Var)])
+ -> [a] -> [a] -> Maybe [(Var, Var)]
+matchList match xs_l xs_r = fmap concat (zipWithEqualM match xs_l xs_r)
+
+matchMaybe :: (a -> a -> (Var, Var))
+ -> Maybe a -> Maybe a -> Maybe [(Var, Var)]
+matchMaybe _ Nothing Nothing = Just []
+matchMaybe f (Just x_l) (Just x_r) = Just [f x_l x_r]
+matchMaybe _ _ _ = Nothing
+
+matchEC :: Stack -> Stack -> Maybe ([(Var, Var)], [(Var, Var)])
+matchEC k_l k_r = fmap combine $ zipWithEqualM (\kf_l kf_r -> matchECFrame (tagee kf_l) (tagee kf_r)) k_l k_r
+ where combine = (concat *** concat) . unzip
+
+matchECFrame :: StackFrame -> StackFrame -> Maybe ([(Var, Var)], [(Var, Var)])
+matchECFrame (Apply x_l') (Apply x_r') = Just ([], [matchVar x_l' x_r'])
+matchECFrame (Scrutinise in_alts_l) (Scrutinise in_alts_r) = fmap ([],) $ matchInAlts matchIdSupply in_alts_l in_alts_r
+matchECFrame (PrimApply pop_l in_vs_l in_es_l) (PrimApply pop_r in_vs_r in_es_r) = fmap ([],) $ guard (pop_l == pop_r) >> liftM2 (++) (matchList (matchInValue matchIdSupply) in_vs_l in_vs_r) (matchList (matchInTerm matchIdSupply) in_es_l in_es_r)
+matchECFrame (Update x_l') (Update x_r') = Just ([matchVar x_l' x_r'], [])
+matchECFrame _ _ = Nothing
+
+-- Returns a renaming from the list only if the list maps a "left" variable to a unique "right" variable
+safeMkRenaming :: [(Var, Var)] -> Maybe Renaming
+safeMkRenaming eqs = guard (all (\(x_l, x_r) -> safeRename "safeMkRenaming" rn x_l == x_r) eqs) >> return rn
+ where rn = mkRenaming eqs
+
+matchRigidBinders :: [(Var, Var)] -> [(Var, Var)] -> Maybe [(Var, Var)]
+matchRigidBinders bound_eqs eqs = do
+ occursCheck bound_eqs eqs
+ return $ filter (`notElem` bound_eqs) eqs
+
+-- The occurs check is trigged by one of these two situations:
+-- x |-> Just y_l; (update y_l)<x> `match` x |-> Just free; (update y_r)<x> Can't instantiate y_l with free since its not a template var
+-- x |-> Just tmpl; (update y_l)<x> `match` x |-> Just y_r; (update y_r)<x> Can't instantiate tmpl with y_r since y_r is bound locally
+occursCheck :: [(Var, Var)] -> [(Var, Var)] -> Maybe ()
+occursCheck bound_eqs eqs = guard $ not $ any (\(x_l, x_r) -> any (\(bound_x_l, bound_x_r) -> (x_l == bound_x_l) /= (x_r == bound_x_r)) bound_eqs) eqs
+
+-- NB: if there are dead bindings in the left PureHeap then the output Renaming will not contain a renaming for their binders.
+matchHeapExact :: PureHeap -> PureHeap -> ([(Var, Var)], [(Var, Var)]) -> Maybe Renaming
+matchHeapExact init_h_l init_h_r (bound_eqs, free_eqs) = do
+ -- 1) Find the initial matching by simply recursively matching used bindings from the Left
+ -- heap against those from the Right heap (if any)
+ eqs <- matchPureHeapExact matchIdSupply bound_eqs free_eqs init_h_l init_h_r
+ -- 2) Perhaps we violate the occurs check?
+ occursCheck bound_eqs eqs
+ -- 3) If the left side var was free, we might have assumed two different corresponding rights for it. This is not necessarily a problem:
+ -- ()<(a, a)> `match` c |-> True; d |-> True; ()<(c, d)>
+ -- ()<(a, a)> `match` c |-> True; d |-> c; ()<(c, d)>
+ -- But for now I'm going to mandate that the mapping must be trivially injective.
+ safeMkRenaming eqs
+
+matchPureHeapExact :: IdSupply -> [(Var, Var)] -> [(Var, Var)] -> PureHeap -> PureHeap -> Maybe [(Var, Var)]
+matchPureHeapExact ids bound_eqs free_eqs init_h_l init_h_r = do
+ -- 1) Find the initial matching by simply recursively matching used bindings from the Left
+ -- heap against those from the Right heap (if any)
+ eqs <- matchPureHeap ids bound_eqs free_eqs init_h_l init_h_r
+ -- 2) The outgoing equalities should only relate x_l's that are not bound by init_h_l
+ -- because we don't the local bound variables I've generated from matchingIdSupply "leaking" upwards
+ eqs <- return $ filter (\(x_l, _x_r) -> x_l `M.notMember` init_h_l) eqs
+ -- 3) Now the problem is that there might be some bindings in the Right heap that are referred
+ -- to by eqs. We want an exact match, so we can't allow that.
+ guard $ all (\(_x_l, x_r) -> x_r `M.notMember` init_h_r) eqs
+ -- 4) We now know that all of the variables bound by both init_h_l and init_h_r are not mentioned
+ -- in the outgoing equalities, which is what we want for an exact match.
+ -- NB: We use this function when matching letrecs, so don't necessarily want to build a renaming immediately
+ return eqs
+
+matchPureHeap :: IdSupply -> [(Var, Var)] -> [(Var, Var)] -> PureHeap -> PureHeap -> Maybe [(Var, Var)]
+matchPureHeap ids bound_eqs free_eqs init_h_l init_h_r = go bound_eqs free_eqs init_h_l init_h_r
+ where
+ -- Utility function used to deal with work-duplication issues when matching
+ deleteExpensive x m | Just (_, e) <- M.lookup x m, not (taggedTermIsCheap e) = M.delete x m
+ | otherwise = m
+
+ -- NB: must respect work-sharing for non-values
+ -- x |-> e1, y |-> e1; (x, y) `match` x |-> e1; (x, x) == Nothing
+ -- x |-> e1; (x, x) `match` x |-> e1; y |-> e1; (x, y) == Nothing (though this is more questionable, it seems a consistent choice)
+ -- NB: treat equal values as equal regardless of duplication
+ -- x |-> v, y |-> v; (x, y) `match` x |-> v; (x, x) /= Nothing
+ -- TODO: look through variables on both sides
+ -- x |-> e1; (x, x) `match` x |-> e1; y |-> x `match` (x, y) /= Nothing
+ -- x |-> e1, y |-> x; (x, y) `match` x |-> e1 `match` (x, x) /= Nothing
+ go known [] _ _ = Just known
+ go known ((x_l, x_r):free_eqs) h_l h_r
+ -- Perhaps we have already assumed this equality is true?
+ | (x_l, x_r) `elem` known = go known free_eqs h_l h_r
+ -- Perhaps the left side is bound, so we need to match it against a corresponding right?
+ | Just in_e_l <- M.lookup x_l h_l = M.lookup x_r h_r >>= \in_e_r -> matchInTerm ids in_e_l in_e_r >>= \extra_free_eqs -> go ((x_l, x_r) : known) (extra_free_eqs ++ free_eqs) (deleteExpensive x_l h_l) (deleteExpensive x_r h_r)
+ -- Perhaps the left side was originally bound, but we already matched it against something else?
+ | M.member x_l init_h_l = Nothing
+ -- The left side is free, so assume that we can instantiate x_l to x_r (x_l may be bound above, x_r may be bound here or above):
+ | otherwise = go ((x_l, x_r) : known) free_eqs h_l h_r
31 Supercompile/Residualise.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE ViewPatterns #-}
+module Supercompile.Residualise where
+
+import Evaluator.Syntax
+
+import Core.Renaming
+import Core.Syntax
+
+import Utilities
+
+import qualified Data.Map as M
+
+
+residualiseState :: State -> Out Term
+residualiseState (heap, k, in_e) = residualiseHeap heap (\ids -> residualiseStack ids k (detagTerm (renameIn renameTaggedTerm ids in_e)))
+
+residualiseHeap :: Heap -> (IdSupply -> ([(Out Var, Out Term)], Out Term)) -> Out Term
+residualiseHeap (Heap h ids) (($ ids) -> (floats, e)) = letRec (residualisePureHeap ids h ++ floats) e
+
+residualisePureHeap :: IdSupply -> PureHeap -> [(Out Var, Out Term)]
+residualisePureHeap ids h = [(x', detagTerm $ renameIn renameTaggedTerm ids in_e) | (x', in_e) <- M.toList h]
+
+residualiseStack :: IdSupply -> Stack -> Out Term -> ([(Out Var, Out Term)], Out Term)
+residualiseStack _ [] e = ([], e)
+residualiseStack ids (kf:k) (residualiseStackFrame ids (tagee kf) -> (floats, e)) = first (floats ++) $ residualiseStack ids k e
+
+residualiseStackFrame :: IdSupply -> StackFrame -> Out Term -> ([(Out Var, Out Term)], Out Term)
+residualiseStackFrame _ (Apply x2') e1 = ([], e1 `app` x2')
+residualiseStackFrame ids (Scrutinise in_alts) e = ([], case_ e (detagAlts $ renameIn renameTaggedAlts ids in_alts))
+residualiseStackFrame ids (PrimApply pop in_vs es') e = ([], primOp pop (map (value . detagValue . renameIn renameTaggedValue ids) in_vs ++ [e] ++ map (detagTerm . renameIn renameTaggedTerm ids) es'))
+residualiseStackFrame _ (Update x') e = ([(x', e)], var x')
429 Supercompile/Split.hs
@@ -0,0 +1,429 @@
+{-# LANGUAGE ViewPatterns, TupleSections, PatternGuards #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module Supercompile.Split (split) where
+
+import Core.FreeVars
+import Core.Renaming
+import Core.Syntax
+
+import Evaluator.Evaluate (step)
+import Evaluator.FreeVars
+import Evaluator.Syntax
+
+import Name
+import Renaming
+import Utilities
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+
+--
+-- == Gathering entry information for the splitter ==
+--
+
+data Entered = Once (Maybe Id) -- ^ The Id is a context identifier: if a binding is Entered twice from the same context it's really a single Entrance. Nothing signifies the residual context (i.e. there is no associated float)
+ | Many
+ deriving (Eq, Show)
+
+instance Pretty Entered where
+ pPrint = text . show
+
+isOnce :: Entered -> Bool
+isOnce (Once _) = True
+isOnce _ = False
+
+plusEntered :: Entered -> Entered -> Entered
+plusEntered (Once mb_id1) (Once mb_id2)
+ | mb_id1 == mb_id2 = Once mb_id1
+ | otherwise = {- traceRender ("Once promotion", mb_id1, mb_id2) -} Many
+plusEntered _ _ = Many
+
+type EnteredEnv = M.Map (Out Var) Entered
+
+emptyEnteredEnv :: EnteredEnv
+emptyEnteredEnv = M.empty
+
+mkEnteredEnv :: Entered -> FreeVars -> EnteredEnv
+mkEnteredEnv ent = M.fromList . map (, ent) . S.toList
+
+plusEnteredEnv :: EnteredEnv -> EnteredEnv -> EnteredEnv
+entenv1 `plusEnteredEnv` entenv2 = M.unionWith plusEntered entenv1 entenv2
+
+plusEnteredEnvs :: [EnteredEnv] -> EnteredEnv
+plusEnteredEnvs = foldr plusEnteredEnv emptyEnteredEnv
+
+
+--
+-- == The splitter ==
+--
+
+
+split :: Monad m
+ => (State -> m (FreeVars, Out Term))
+ -> State
+ -> m (FreeVars, Out Term)
+split opt (simplify -> (Heap h ids, k, qa)) = uncurry3 optimiseSplit (split' opt (Heap h ids) k (splitQA ids qa))
+
+-- Non-expansive simplification that we can safely do just before splitting to make the splitter a bit simpler
+data QA = Question (Out Var)
+ | Answer (In TaggedValue)
+
+simplify :: State -> (Heap, Stack, Tagged QA)
+simplify s = expectHead "simplify" [res | s <- s : unfoldr (\s -> fmap (\x -> (x, x)) (step s)) s, Just res <- [stop s]]
+ where
+ stop (h, k, (rn, TaggedTerm (Tagged tg (Var x)))) = Just (h, k, Tagged tg (Question (rename rn x)))
+ stop (h, k, (rn, TaggedTerm (Tagged tg (Value v)))) = Just (h, k, Tagged tg (Answer (rn, v)))
+ stop _ = Nothing
+
+-- Discard dead bindings:
+-- let x = ...
+-- in 1
+-- ==>
+-- 1
+--
+-- But include transitively needed ones:
+-- let w = ...
+-- x = ...
+-- y = ... x ...
+-- z = ... y ...
+-- in z
+-- ==>
+-- let z = let x = ...
+-- y = ... x ...
+-- in ... y ...
+-- in z
+--
+-- Inline values and linear things into residual bindings:
+-- let x = ... y ...
+-- y = ...
+-- in \_ -> ... x ...
+-- ===>
+-- let x = let y = ...
+-- in ... y ...
+-- in \_ -> ... x ...
+--
+-- Inline values into residual non-linear things:
+-- let x = (y:ys)
+-- in \_ -> ... x ...
+-- ==>
+-- \_ -> let x = (y:ys)
+-- in ... x ...
+--
+-- Do NOT inline linear things into non-linear things:
+-- let x = (y:ys)
+-- y = ...
+-- in \_ -> ... x ...
+-- =/=>
+-- \_ -> let x = let y = ...
+-- in (y:ys)
+-- in ... x ...
+-- ===>
+-- let y = ...
+-- in \_ -> let x = (y:ys)
+-- in ... x ...
+--
+-- Inline things that are (apparently) used non-linearly times into linear things:
+-- let w = ...
+-- x = ... w ...
+-- y = ... w ...
+-- z = (x, y)
+-- in Just z
+-- ===>
+-- let z = let w = ...
+-- x = ... w ...
+-- y = ... w ...
+-- in (x, y)
+-- in Just z
+--
+-- Treat non-linearity due only to |case| branches as linearity:
+-- let x = ...
+-- in case unk of C -> ... x ...; D -> ... x ...
+-- ===>
+-- case unk of C -> let x = ... in ... x ...
+-- D -> let x = ... in ... x ...
+--
+-- Let-float things to trivialise them:
+-- let x = let y = ... in (y:xs)
+-- in \_ -> ... x ...
+-- ===>
+-- let y = ....
+-- \_ -> let x = (y:xs) in ... x ...
+--
+-- Note [EC binds something we need to refer to above]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- let z = f x
+-- y = unk + z
+-- x = case y of _ -> 2
+-- in x + 2
+--
+-- After splitting:
+-- let x = 2
+-- in x + 2
+--
+-- That's fine, but how are we going to get a reference to the "x" when residualising the y binding above?
+-- let z = f x
+-- y = unk + z
+-- in case y of _ -> h0
+--
+-- Lacking extra language features, our only option is to under-specialise the floats by inlining less
+-- evaluation context.
+data Bracketed a = Bracketed {
+ rebuild :: [Out Term] -> Out Term, -- Rebuild the full output term given outputs to plug into each hole
+ extra_fvs :: FreeVars, -- Maximum free variables added by the residual wrapped around the holes
+ transfer :: [FreeVars] -> FreeVars, -- Strips any variables bound by the residual out of the hole FVs
+ fillers :: [a] -- Hole-fillers themselves. Can be In TaggedTerm, State or DrivePureState
+ }
+
+optimiseBracketed :: Monad m
+ => (State -> m (FreeVars, Out Term))
+ -> Heap
+ -> Bracketed PureState
+ -> m (FreeVars, Out Term)
+optimiseBracketed opt (Heap h_inlineable ids) b = do
+ let -- We are going to use this helper function to inline any eligible inlinings to produce the expressions for driving
+ transitiveInline :: PureHeap -> PureHeap -> FreeVars -> PureHeap
+ transitiveInline h_inlineable h_output fvs
+ = if M.null h_inline then h_output else transitiveInline h_inlineable' (h_inline `M.union` h_output) fvs'
+ where (h_inline, h_inlineable') = M.partitionWithKey (\x' _ -> x' `S.member` fvs) h_inlineable
+ fvs' = M.fold (\in_e fvs -> fvs `S.union` inFreeVars taggedTermFreeVars in_e) S.empty h_inline
+
+ (fvs', es') <- liftM unzip $ mapM (\pstate@(h, k, in_e) -> opt (Heap (transitiveInline (h_inlineable `M.union` h) M.empty (pureStateFreeVars pstate)) ids, k, in_e)) (fillers b)
+ return (extra_fvs b `S.union` transfer b fvs', rebuild b es')
+
+optimiseSplit :: Monad m
+ => (Bracketed PureState -> m (FreeVars, Out Term))
+ -> M.Map (Out Var) (Bracketed PureState)
+ -> Bracketed PureState
+ -> m (FreeVars, Out Term)
+optimiseSplit optimise_bracketed floats_h floats_compulsory = do
+ -- 1) Recursively drive the compulsory floats
+ (fvs_compulsory', e_compulsory') <- optimise_bracketed floats_compulsory
+
+ -- 2) We now need to think about how we are going to residualise the letrec. We only want to drive (and residualise) as
+ -- much as we actually refer to. This loop does this: it starts by residualising the free variables of the compulsory
+ -- residualisation, and then transitively inlines any bindings whose corresponding binders become free.
+ let residualise xes_resid resid_bvs resid_fvs
+ | M.null h_resid = -- traceRenderM ("residualise", resid_fvs, resid_bvs, (M.map (residualiseBracketed (residualiseState . first3 (flip Heap prettyIdSupply))) floats_h)) $
+ return (resid_fvs S.\\ resid_bvs, xes_resid)
+ | otherwise = {- traceRender ("optimiseSplit", xs_resid') $ -} do
+ -- Recursively drive the new residuals arising from the need to bind the resid_fvs
+ (S.unions -> extra_resid_fvs', es_resid') <- liftM unzip $ mapM optimise_bracketed bracks_resid
+ -- Recurse, because we might now need to residualise and drive even more stuff (as we have added some more FVs and BVs)
+ residualise (xes_resid ++ zip xs_resid' es_resid')
+ (resid_bvs `S.union` M.keysSet h_resid)
+ (resid_fvs `S.union` extra_resid_fvs')
+ where
+ -- When assembling the final list of things to drive, ensure that we exclude already-driven things
+ h_resid = M.filterWithKey (\x _br -> x `S.member` resid_fvs) (floats_h