diff --git a/dist/build/HERMIT/Parser.hs b/dist/build/HERMIT/Parser.hs new file mode 100644 --- /dev/null +++ b/dist/build/HERMIT/Parser.hs @@ -0,0 +1,752 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +module HERMIT.Parser + ( Script + , parseScript + , unparseScript + , unparseExprH + , ExprH(..) + ) where + +import Data.Char (isSpace) +import Data.List (intercalate) + +import Control.Monad ((>=>)) + +import HERMIT.Syntax (isScriptInfixIdChar, isScriptIdFirstChar, isScriptIdChar) +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts + +-- parser produced by Happy Version 1.19.0 + +newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11 = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t4 +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t5 +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t6 +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t7 +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t8 +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t9 +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyIn10 :: t10 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn10 #-} +happyOut10 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t10 +happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut10 #-} +happyIn11 :: t11 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn11 #-} +happyOut11 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> t11 +happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut11 #-} +happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9 t10 t11) -> (Token) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x0e\x00\x1e\x00\x0e\x00\x06\x00\x00\x00\x00\x00\xfd\xff\x01\x00\x00\x00\x1a\x00\x0e\x00\x1a\x00\x0e\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x09\x00\x00\x00\x00\x00\x02\x00\x00\x00\x1a\x00\x0e\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x45\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x4d\x00\x39\x00\x48\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x2d\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xfa\xff\x00\x00\xfa\xff\x00\x00\xfc\xff\xfb\xff\xf9\xff\xf4\xff\xf2\xff\x00\x00\xfa\xff\xe8\xff\xfa\xff\x00\x00\xed\xff\xee\xff\xea\xff\xef\xff\xf1\xff\xf0\xff\xf6\xff\xe7\xff\x00\x00\xe9\xff\xfd\xff\x00\x00\xf3\xff\x00\x00\xfa\xff\xfa\xff\xfe\xff\xf7\xff\xf8\xff\xf5\xff\xeb\xff\xec\xff\x00\x00\xe6\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x04\x00\x01\x00\x05\x00\x02\x00\x08\x00\x05\x00\x03\x00\x04\x00\x05\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\x07\x00\x03\x00\x04\x00\x05\x00\x0e\x00\x06\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x01\x00\x03\x00\x04\x00\x05\x00\x05\x00\x07\x00\x03\x00\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x03\x00\x04\x00\x05\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x1d\x00\x0a\x00\x1a\x00\x23\x00\x1e\x00\x0c\x00\x21\x00\x07\x00\x08\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1c\x00\x0a\x00\x24\x00\x03\x00\x0b\x00\x0c\x00\xff\xff\x25\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x0a\x00\x15\x00\x07\x00\x08\x00\x0c\x00\x25\x00\x03\x00\x00\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x1f\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x20\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x14\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x18\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x1e\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x15\x00\x07\x00\x08\x00\x16\x00\x17\x00\x19\x00\x07\x00\x08\x00\x00\x00\x12\x00\x13\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 25) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11), + (12 , happyReduce_12), + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25) + ] + +happy_n_terms = 15 :: Int +happy_n_nonterms = 8 :: Int + +happyReduce_1 = happySpecReduce_2 0# happyReduction_1 +happyReduction_1 happy_x_2 + happy_x_1 + = case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4 + (CmdName "{" : happy_var_2 + )} + +happyReduce_2 = happySpecReduce_2 0# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4 + (CmdName "}" : happy_var_2 + )} + +happyReduce_3 = happySpecReduce_1 0# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn4 + (happy_var_1 + )} + +happyReduce_4 = happySpecReduce_1 1# happyReduction_4 +happyReduction_4 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_5 = happySpecReduce_0 1# happyReduction_5 +happyReduction_5 = happyIn5 + ([] + ) + +happyReduce_6 = happySpecReduce_1 2# happyReduction_6 +happyReduction_6 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + ([happy_var_1] + )} + +happyReduce_7 = happySpecReduce_3 2# happyReduction_7 +happyReduction_7 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_3 of { happy_var_3 -> + happyIn6 + ([happy_var_1, CmdName "}"] ++ happy_var_3 + )}} + +happyReduce_8 = happySpecReduce_3 2# happyReduction_8 +happyReduction_8 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_3 of { happy_var_3 -> + happyIn6 + (happy_var_1 : happy_var_3 + )}} + +happyReduce_9 = happySpecReduce_2 2# happyReduction_9 +happyReduction_9 happy_x_2 + happy_x_1 + = case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn6 + (happy_var_2 + )} + +happyReduce_10 = happySpecReduce_3 3# happyReduction_10 +happyReduction_10 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> + case happyOut7 happy_x_3 of { happy_var_3 -> + happyIn7 + (AppH (AppH (CmdName happy_var_2) happy_var_1) happy_var_3 + )}}} + +happyReduce_11 = happySpecReduce_1 3# happyReduction_11 +happyReduction_11 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn7 + (happy_var_1 + )} + +happyReduce_12 = happySpecReduce_2 4# happyReduction_12 +happyReduction_12 happy_x_2 + happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + case happyOut9 happy_x_2 of { happy_var_2 -> + happyIn8 + (AppH happy_var_1 happy_var_2 + )}} + +happyReduce_13 = happySpecReduce_1 4# happyReduction_13 +happyReduction_13 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn8 + (happy_var_1 + )} + +happyReduce_14 = happySpecReduce_2 5# happyReduction_14 +happyReduction_14 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (Ident happy_var_2) -> + happyIn9 + (SrcName happy_var_2 + )} + +happyReduce_15 = happySpecReduce_2 5# happyReduction_15 +happyReduction_15 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (InfixOp happy_var_2) -> + happyIn9 + (SrcName happy_var_2 + )} + +happyReduce_16 = happySpecReduce_2 5# happyReduction_16 +happyReduction_16 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (Quote happy_var_2) -> + happyIn9 + (SrcName happy_var_2 + )} + +happyReduce_17 = happySpecReduce_1 5# happyReduction_17 +happyReduction_17 happy_x_1 + = case happyOutTok happy_x_1 of { (Quote happy_var_1) -> + happyIn9 + (CmdName happy_var_1 + )} + +happyReduce_18 = happySpecReduce_1 5# happyReduction_18 +happyReduction_18 happy_x_1 + = case happyOutTok happy_x_1 of { (CoreString happy_var_1) -> + happyIn9 + (CoreH happy_var_1 + )} + +happyReduce_19 = happySpecReduce_3 5# happyReduction_19 +happyReduction_19 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn9 + (ListH happy_var_2 + )} + +happyReduce_20 = happySpecReduce_3 5# happyReduction_20 +happyReduction_20 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn9 + (happy_var_2 + )} + +happyReduce_21 = happySpecReduce_1 5# happyReduction_21 +happyReduction_21 happy_x_1 + = case happyOutTok happy_x_1 of { (Ident happy_var_1) -> + happyIn9 + (CmdName happy_var_1 + )} + +happyReduce_22 = happySpecReduce_1 6# happyReduction_22 +happyReduction_22 happy_x_1 + = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn10 + (happy_var_1 + )} + +happyReduce_23 = happySpecReduce_0 6# happyReduction_23 +happyReduction_23 = happyIn10 + ([] + ) + +happyReduce_24 = happySpecReduce_1 7# happyReduction_24 +happyReduction_24 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn11 + ([happy_var_1] + )} + +happyReduce_25 = happySpecReduce_3 7# happyReduction_25 +happyReduction_25 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + case happyOut11 happy_x_3 of { happy_var_3 -> + happyIn11 + (happy_var_1 : happy_var_3 + )}} + +happyNewToken action sts stk [] = + happyDoAction 14# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + ParenLeft -> cont 1#; + ParenRight -> cont 2#; + ScopeStart -> cont 3#; + ScopeEnd -> cont 4#; + ListStart -> cont 5#; + ListDelim -> cont 6#; + ListEnd -> cont 7#; + StmtEnd -> cont 8#; + Tick -> cont 9#; + CoreString happy_dollar_dollar -> cont 10#; + Quote happy_dollar_dollar -> cont 11#; + Ident happy_dollar_dollar -> cont 12#; + InfixOp happy_dollar_dollar -> cont 13#; + _ -> happyError' (tk:tks) + } + +happyError_ 14# tk tks = happyError' tks +happyError_ _ tk tks = happyError' (tk:tks) + +happyThen :: () => Either String a -> (a -> Either String b) -> Either String b +happyThen = (>>=) +happyReturn :: () => a -> Either String a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> Either String a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [(Token)] -> Either String a +happyError' = parseError + +parser tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + + +parseError :: [Token] -> Either String a +parseError ts = Left $ "Parse error: " ++ show ts + +-- | A simple expression language AST, for things parsed from 'String' or JSON structures. +data ExprH + = SrcName String -- ^ Variable names (refers to source code). + | CmdName String -- ^ Commands (to be looked up in 'HERMIT.Dictionary'). + | AppH ExprH ExprH -- ^ Application. + | CoreH String -- ^ Core Fragment + | ListH [ExprH] -- ^ List of expressions + deriving (Eq, Show) + +data Token + = ParenLeft + | ParenRight + | ScopeStart + | ScopeEnd + | ListStart + | ListDelim + | ListEnd + | StmtEnd + | Tick + | CoreString String + | Quote String + | Ident String + | InfixOp String + deriving (Eq, Show) + +lexError :: String -> Either String a +lexError msg = Left ("Lexer error: " ++ msg) + +lexer :: String -> Either String [Token] +lexer [] = Right [] +lexer ('\n':cs) = fmap (StmtEnd:) $ lexer cs +lexer (';' :cs) = fmap (StmtEnd:) $ lexer cs +lexer ('(' :cs) = fmap (ParenLeft:) $ lexer cs +lexer (')' :cs) = fmap (ParenRight:) $ lexer cs +lexer ('{' :cs) = fmap (ScopeStart:) $ lexer cs +lexer ('}' :cs) = fmap (ScopeEnd:) $ lexer cs +lexer ('\'':cs) = fmap (Tick:) $ lexer cs +lexer ('\"':cs) = do (str,cs') <- lexString cs + fmap (Quote str:) $ lexer cs' +lexer ('[':'|':cs) = do (str,cs') <- lexCore cs + fmap (CoreString str:) $ lexer cs' +lexer ('-':'-':cs) = let (_,s') = span (/= '\n') cs in lexer s' +lexer ('[' :cs) = fmap (ListStart:) $ lexer cs +lexer (',' :cs) = fmap (ListDelim:) $ lexer cs +lexer (']' :cs) = fmap (ListEnd:) $ lexer cs +lexer s@(c:cs) | isSpace c = lexer cs + | isScriptIdFirstChar c = let (i,s') = span isScriptIdChar s + in fmap (Ident i:) $ lexer s' + | isScriptInfixIdChar c = let (op,s') = span isScriptInfixIdChar s + in fmap (InfixOp op:) $ lexer s' +lexer s = lexError $ "no match on " ++ s + +lexString :: String -> Either String (String,String) +lexString ('\"':cs) = Right ([],cs) +lexString ('\\':'\"':cs) = do (c',r) <- lexString cs + return ('"':c',r) +lexString (c:cs) = do (c',r) <- lexString cs + return (c:c',r) +lexString [] = lexError "no matching quote" + +lexCore :: String -> Either String (String,String) +lexCore ('|':']':rest) = Right ([],rest) +lexCore (c:cs) = do (c',r) <- lexCore cs + return (c:c',r) +lexCore [] = lexError "no closing |]" + +--------------------------------------------- + +-- | Use ghci Parser.hs to run this test function. +test = do + ln <- getLine + case ln of + "quit" -> return () + _ -> do print $ lexer ln + print $ parseScript ln + test + +type Script = [ExprH] + +parseScript :: String -> Either String Script +parseScript = lexer >=> parser + +--------------------------------------------- + +unparseScript :: Script -> String +unparseScript = intercalate " ; " . map unparseExprH + +unparseExprH :: ExprH -> String +unparseExprH (SrcName nm) + | nm /= "" && (all isScriptInfixIdChar nm || isScriptIdFirstChar (head nm) && all isScriptIdChar (tail nm)) = "'" ++ nm + | otherwise = "'\"" ++ concatMap escape nm ++ "\"" + where escape '\"' = "\\\"" + escape c = [c] +unparseExprH (CmdName nm) + | nm == "{" = "{ " + | nm == "}" = " }" + | all isScriptIdChar nm = nm + | otherwise = show nm -- with quotes +unparseExprH (AppH (AppH (CmdName nm) e1) e2) + | all isScriptInfixIdChar nm + = unparseAtom e1 ++ " " ++ nm ++ " " ++ unparseAtom e2 +unparseExprH (AppH e1 e2) = unparseExprH e1 ++ " " ++ unparseAtom e2 +unparseExprH (CoreH s) = "[|" ++ s ++ "|]" +unparseExprH (ListH es) = "[" ++ intercalate "," (map unparseExprH es) ++ "]" + +unparseAtom :: ExprH -> String +unparseAtom e@(AppH {}) = "(" ++ unparseExprH e ++ ")" +unparseAtom e = unparseExprH e + +--------------------------------------------- +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 13 "templates/GenericTemplate.hs" #-} + + + + + +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif +{-# LINE 45 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 66 "templates/GenericTemplate.hs" #-} + +{-# LINE 76 "templates/GenericTemplate.hs" #-} + +{-# LINE 85 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else False + action + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 169 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/dist/build/HERMIT/ParserCore.hs b/dist/build/HERMIT/ParserCore.hs new file mode 100644 --- /dev/null +++ b/dist/build/HERMIT/ParserCore.hs @@ -0,0 +1,624 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE CPP #-} + module HERMIT.ParserCore (parseCore, parseCoreExprT, parse2beforeBiR, parse3beforeBiR) where + +import Control.Arrow +import Control.Monad.Reader +import Data.Char (isSpace, isDigit) + +import HERMIT.Context +import HERMIT.External +import HERMIT.GHC +import HERMIT.Kure +import HERMIT.Monad +import HERMIT.Syntax (isCoreInfixIdChar, isCoreIdFirstChar, isCoreIdChar) + +import HERMIT.Dictionary.Common + +import Language.KURE.MonadCatch (prefixFailMsg) + +import Language.Haskell.TH as TH +import qualified Data.Array as Happy_Data_Array +import qualified GHC.Exts as Happy_GHC_Exts + +-- parser produced by Happy Version 1.19.0 + +newtype HappyAbsSyn t4 t5 t6 t7 t8 t9 = HappyAbsSyn HappyAny +#if __GLASGOW_HASKELL__ >= 607 +type HappyAny = Happy_GHC_Exts.Any +#else +type HappyAny = forall a . a +#endif +happyIn4 :: t4 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9) +happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn4 #-} +happyOut4 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t4 +happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut4 #-} +happyIn5 :: t5 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9) +happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn5 #-} +happyOut5 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t5 +happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut5 #-} +happyIn6 :: t6 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9) +happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn6 #-} +happyOut6 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t6 +happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut6 #-} +happyIn7 :: t7 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9) +happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn7 #-} +happyOut7 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t7 +happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut7 #-} +happyIn8 :: t8 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9) +happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn8 #-} +happyOut8 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t8 +happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut8 #-} +happyIn9 :: t9 -> (HappyAbsSyn t4 t5 t6 t7 t8 t9) +happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn9 #-} +happyOut9 :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> t9 +happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut9 #-} +happyInTok :: (Token) -> (HappyAbsSyn t4 t5 t6 t7 t8 t9) +happyInTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyInTok #-} +happyOutTok :: (HappyAbsSyn t4 t5 t6 t7 t8 t9) -> (Token) +happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOutTok #-} + + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\xf8\xff\xf8\xff\xf8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x0b\x00\x18\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\x00\x00\x00\x00\xfe\xff\xfc\xff\xf8\xff\xf7\xff\xf9\xff\x00\x00\xf4\xff\xf6\xff\xf5\xff\x00\x00\x00\x00\xfa\xff\xfd\xff\xfb\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x0c\x00\x0d\x00\x0d\x00\x0c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x1c\x00\x22\x00\x1e\x00\x1c\x00\x20\x00\x1e\x00\xff\xff\x20\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x02\x00\x03\x00\x04\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x08\x00\x0e\x00\x10\x00\x08\x00\x0c\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x09\x00\xff\xff\x0a\x00\x09\x00\x0b\x00\x0a\x00\x00\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x0e\x00\x04\x00\x05\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (1, 11) [ + (1 , happyReduce_1), + (2 , happyReduce_2), + (3 , happyReduce_3), + (4 , happyReduce_4), + (5 , happyReduce_5), + (6 , happyReduce_6), + (7 , happyReduce_7), + (8 , happyReduce_8), + (9 , happyReduce_9), + (10 , happyReduce_10), + (11 , happyReduce_11) + ] + +happy_n_terms = 35 :: Int +happy_n_nonterms = 6 :: Int + +happyReduce_1 = happySpecReduce_1 0# happyReduction_1 +happyReduction_1 happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + happyIn4 + (happy_var_1 + )} + +happyReduce_2 = happySpecReduce_2 1# happyReduction_2 +happyReduction_2 happy_x_2 + happy_x_1 + = case happyOut5 happy_x_1 of { happy_var_1 -> + case happyOut6 happy_x_2 of { happy_var_2 -> + happyIn5 + (App happy_var_1 happy_var_2 + )}} + +happyReduce_3 = happySpecReduce_1 1# happyReduction_3 +happyReduction_3 happy_x_1 + = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5 + (happy_var_1 + )} + +happyReduce_4 = happySpecReduce_3 2# happyReduction_4 +happyReduction_4 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn6 + (happy_var_2 + )} + +happyReduce_5 = happyMonadReduce 2# 2# happyReduction_5 +happyReduction_5 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (( lookupName "()" Var) + ) (\r -> happyReturn (happyIn6 r)) + +happyReduce_6 = happySpecReduce_1 2# happyReduction_6 +happyReduction_6 happy_x_1 + = case happyOut9 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_7 = happySpecReduce_1 2# happyReduction_7 +happyReduction_7 happy_x_1 + = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_8 = happySpecReduce_1 2# happyReduction_8 +happyReduction_8 happy_x_1 + = case happyOut8 happy_x_1 of { happy_var_1 -> + happyIn6 + (happy_var_1 + )} + +happyReduce_9 = happyMonadReduce 1# 3# happyReduction_9 +happyReduction_9 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (Tinteger happy_var_1) -> + ( mkIntExpr' happy_var_1)} + ) (\r -> happyReturn (happyIn7 r)) + +happyReduce_10 = happyMonadReduce 1# 4# happyReduction_10 +happyReduction_10 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (Tstring happy_var_1) -> + ( lift $ mkStringExpr happy_var_1)} + ) (\r -> happyReturn (happyIn8 r)) + +happyReduce_11 = happyMonadReduce 1# 5# happyReduction_11 +happyReduction_11 (happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (Tname happy_var_1) -> + ( lookupName happy_var_1 varToCoreExpr)} + ) (\r -> happyReturn (happyIn9 r)) + +happyNewToken action sts stk [] = + happyDoAction 34# notHappyAtAll action sts stk [] + +happyNewToken action sts stk (tk:tks) = + let cont i = happyDoAction i tk action sts stk tks in + case tk of { + Tforall -> cont 1#; + Trec -> cont 2#; + Tlet -> cont 3#; + Tin -> cont 4#; + Tcase -> cont 5#; + Tof -> cont 6#; + Tcast -> cont 7#; + Tnote -> cont 8#; + Texternal -> cont 9#; + Tlocal -> cont 10#; + Twild -> cont 11#; + Toparen -> cont 12#; + Tcparen -> cont 13#; + Tobrace -> cont 14#; + Tcbrace -> cont 15#; + Thash -> cont 16#; + Teq -> cont 17#; + Tcolon -> cont 18#; + Tcoloncolon -> cont 19#; + Tcoloneqcolon -> cont 20#; + Tstar -> cont 21#; + Tarrow -> cont 22#; + Tlambda -> cont 23#; + Tat -> cont 24#; + Tdot -> cont 25#; + Tquestion -> cont 26#; + Tsemicolon -> cont 27#; + Tname happy_dollar_dollar -> cont 28#; + Tcname happy_dollar_dollar -> cont 29#; + Tinteger happy_dollar_dollar -> cont 30#; + Trational happy_dollar_dollar -> cont 31#; + Tstring happy_dollar_dollar -> cont 32#; + Tchar happy_dollar_dollar -> cont 33#; + _ -> happyError' (tk:tks) + } + +happyError_ 34# tk tks = happyError' tks +happyError_ _ tk tks = happyError' (tk:tks) + +happyThen :: () => CoreParseM a -> (a -> CoreParseM b) -> CoreParseM b +happyThen = (>>=) +happyReturn :: () => a -> CoreParseM a +happyReturn = (return) +happyThen1 m k tks = (>>=) m (\a -> k a tks) +happyReturn1 :: () => a -> b -> CoreParseM a +happyReturn1 = \a tks -> (return) a +happyError' :: () => [(Token)] -> CoreParseM a +happyError' = parseError + +parser tks = happySomeParser where + happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x)) + +happySeq = happyDontSeq + + +mkIntExpr' :: Integer -> CoreParseM CoreExpr +#if __GLASGOW_HASKELL__ > 706 +mkIntExpr' i = do + dflags <- lift getDynFlags + return $ mkIntExpr dflags i +#else +mkIntExpr' i = return $ mkIntExpr i +#endif + +lookupName :: String -> (Id -> CoreExpr) -> CoreParseM CoreExpr +lookupName nm k = do + c <- ask + v <- lift $ prefixFailMsg (nm ++ " lookup: ") $ findId (TH.mkName nm) c + return (k v) + +type CoreParseM a = ReaderT HermitC HermitM a + +parseError :: Monad m => [Token] -> m a +parseError ts = fail $ "core parse error: " ++ show ts + +data Token + = Tforall + | Trec + | Tlet + | Tin + | Tcase + | Tof + | Tcast + | Tnote + | Texternal + | Tlocal + | Twild -- + | Toparen -- + | Tcparen -- + | Tobrace + | Tcbrace + | Thash + | Teq + | Tcolon -- + | Tcoloncolon -- + | Tcoloneqcolon + | Tstar + | Tarrow + | Tlambda -- + | Tat + | Tdot + | Tquestion + | Tsemicolon + | Tname String + | Tcname String + | Tinteger Integer + | Trational Float + | Tstring String + | Tchar Char + deriving (Eq, Show) + +lexer :: String -> Either String [Token] +lexer [] = Right [] +lexer ('_' :cs) = fmap (Twild:) $ lexer cs +lexer ('(' :cs) = fmap (Toparen:) $ lexer cs +lexer (')' :cs) = fmap (Tcparen:) $ lexer cs +lexer (':':':':cs) = fmap (Tcoloncolon:) $ lexer cs +-- lexer (':' :cs) = fmap (Tcolon:) $ lexer cs +lexer ('\\':cs) = fmap (Tlambda:) $ lexer cs +lexer ('-':'>':cs) = fmap (Tarrow:) $ lexer cs +lexer ('\"':cs) = let (str,rest) = span (/='\"') cs + in case rest of + ('\"':cs') -> fmap (Tstring str:) $ lexer cs' + _ -> Left "lexer: no matching quote" +lexer s@(c:cs) | isSpace c = lexer cs + | isDigit c = let (i,s') = span isDigit s + in fmap (Tinteger (read i):) $ lexer s' + | isCoreIdFirstChar c = let (i,s') = span isCoreIdChar s + in fmap (Tname i:) $ lexer s' + | isCoreInfixIdChar c = let (op,s') = span isCoreInfixIdChar s + in fmap (Tname op:) $ lexer s' +lexer s = Left $ "lexer: no match on " ++ s + +--------------------------------------------- + +parseCore :: CoreString -> HermitC -> HermitM CoreExpr +parseCore (CoreString s) c = + case lexer s of + Left msg -> fail msg + Right tokens -> runReaderT (parser tokens) c + +--------------------------------------------- + +-- These three should probably go somewhere else. + +-- | Parse a 'CoreString' to a 'CoreExpr', using the current context. +parseCoreExprT :: CoreString -> TranslateH a CoreExpr +parseCoreExprT = contextonlyT . parseCore + +parse2beforeBiR :: (CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> BiRewriteH a +parse2beforeBiR f s1 s2 = beforeBiR (parseCoreExprT s1 &&& parseCoreExprT s2) (uncurry f) + +parse3beforeBiR :: (CoreExpr -> CoreExpr -> CoreExpr -> BiRewriteH a) -> CoreString -> CoreString -> CoreString -> BiRewriteH a +parse3beforeBiR f s1 s2 s3 = beforeBiR ((parseCoreExprT s1 &&& parseCoreExprT s2) &&& parseCoreExprT s3) ((uncurry.uncurry) f) + +--------------------------------------------- +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + +{-# LINE 13 "templates/GenericTemplate.hs" #-} + + + + + +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif +{-# LINE 45 "templates/GenericTemplate.hs" #-} + + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + +{-# LINE 66 "templates/GenericTemplate.hs" #-} + +{-# LINE 76 "templates/GenericTemplate.hs" #-} + +{-# LINE 85 "templates/GenericTemplate.hs" #-} + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else False + action + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + +{-# LINE 169 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. diff --git a/driver/Main.hs b/driver/Main.hs --- a/driver/Main.hs +++ b/driver/Main.hs @@ -25,7 +25,8 @@ ," hermit Foo.hs +Main Foo.hss +Other.Module.Name Bar.hss" ," hermit Foo.hs -- -ddump-simpl -ddump-to-file" ,"" - ,"If a module name is not supplied, the module main:Main is assumed." + ,"A * may be used for the module name. * matches any module." + ,"If a module name is not supplied, * is assumed." ,"" ,"HERMIT_ARGS" ," -opt=MODULE : where MODULE is the module containing a HERMIT optimization plugin" @@ -49,7 +50,7 @@ main1 [] = usage main1 args@[file_nm,script_nm] = do e <- doesFileExist script_nm - if e then main4 file_nm [] [("Main", [script_nm])] [] else main2 args + if e then main4 file_nm [] [("*", [script_nm])] [] else main2 args main1 other = main2 other main2 (file_nm:rest) = case span (/= "--") rest of @@ -65,7 +66,7 @@ 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", [])] ghc_args +main4 file_nm hermit_args [] ghc_args = main4 file_nm hermit_args [("*", [])] ghc_args main4 file_nm hermit_args module_args ghc_args = do putStrLn $ "[starting " ++ hermit_version ++ " on " ++ file_nm ++ "]" let (pluginName, hermit_args') = getPlugin hermit_args diff --git a/hermit.cabal b/hermit.cabal --- a/hermit.cabal +++ b/hermit.cabal @@ -1,5 +1,5 @@ Name: hermit -Version: 0.3.1.0 +Version: 0.3.2.0 Synopsis: Haskell Equational Reasoning Model-to-Implementation Tunnel Description: HERMIT uses Haskell to express semi-formal models, @@ -30,12 +30,12 @@ . @ $ hermit Reverse.hs Reverse.hss resume - [starting HERMIT v0.3.1.0 on Reverse.hs] + [starting HERMIT v0.3.2.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main:Reverse.hss -fplugin-opt=HERMIT:Main:resume [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ... - Loading package hermit-0.3.1.0 ... linking ... done. + Loading package hermit-0.3.2.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) Linking Reverse ... $ ./Reverse @@ -46,12 +46,12 @@ . @ $ hermit Reverse.hs - [starting HERMIT v0.3.1.0 on Reverse.hs] + [starting HERMIT v0.3.2.0 on Reverse.hs] % ghc Reverse.hs -fforce-recomp -O2 -dcore-lint -fexpose-all-unfoldings -fsimple-list-literals -fplugin=HERMIT -fplugin-opt=HERMIT:Main: [1 of 2] Compiling HList ( HList.hs, HList.o ) Loading package ghc-prim ... linking ... done. ... - Loading package hermit-0.3.1.0 ... linking ... done. + Loading package hermit-0.3.2.0 ... linking ... done. [2 of 2] Compiling Main ( Reverse.hs, Reverse.o ) ===================== Welcome to HERMIT ===================== HERMIT is a toolkit for the interactive transformation of GHC diff --git a/src/HERMIT.hs b/src/HERMIT.hs --- a/src/HERMIT.hs +++ b/src/HERMIT.hs @@ -1,7 +1,11 @@ module HERMIT (plugin) where +import Data.Maybe (fromMaybe) + import HERMIT.GHC import HERMIT.Optimize +import HERMIT.Plugin (getPhaseFlag) plugin :: Plugin -plugin = optimize $ \ options -> phase 0 $ interactive [] options +plugin = optimize $ \ options -> let (pn,opts) = fromMaybe (0,options) (getPhaseFlag options) + in phase pn $ interactive [] opts diff --git a/src/HERMIT/Context.hs b/src/HERMIT/Context.hs --- a/src/HERMIT/Context.hs +++ b/src/HERMIT/Context.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, InstanceSigs #-} module HERMIT.Context ( -- * HERMIT Contexts @@ -12,7 +12,11 @@ , HermitBindingSite(..) , BindingDepth , HermitBinding + , hbDepth + , hbSite + , hbPath , hermitBindingSiteExpr + , hermitBindingSummary , hermitBindingExpr -- ** Adding bindings to contexts , AddBindings(..) @@ -62,13 +66,17 @@ -- Bound expressions cannot be inlined without checking for shadowing issues (using the depth information). data HermitBindingSite = LAM -- ^ A lambda-bound variable. | NONREC CoreExpr -- ^ A non-recursive binding of an expression. - | REC CoreExpr -- ^ A (potentially) recursive binding of an expression. - | SELFREC -- ^ A (potentially) recursive binding of a superexpression of the current node. + | REC CoreExpr -- ^ A recursive binding that does not depend on the current expression (i.e. we're not in the binding group of that binding). + | SELFREC -- ^ A recursive binding of a superexpression of the current node (i.e. we're in the RHS of that binding). + | MUTUALREC CoreExpr -- ^ A recursive binding that is mutually recursive with the binding under consideration (i.e. we're in another definition in the same recursive binding group.). | CASEALT -- ^ A variable bound in a case alternative. | CASEWILD CoreExpr (AltCon,[Var]) -- ^ A case wildcard binder. We store both the scrutinised expression, and the case alternative 'AltCon' and variables. | FORALL -- ^ A universally quantified type variable. -type HermitBinding = (BindingDepth, HermitBindingSite) +data HermitBinding = HB { hbDepth :: BindingDepth + , hbSite :: HermitBindingSite + , hbPath :: AbsolutePathH + } -- | Retrieve the expression in a 'HermitBindingSite', if there is one. hermitBindingSiteExpr :: HermitBindingSite -> KureM CoreExpr @@ -76,14 +84,26 @@ LAM -> fail "variable is lambda-bound, not bound to an expression." NONREC e -> return e REC e -> return e + MUTUALREC e -> return e SELFREC -> fail "identifier recursively refers to the expression under consideration." CASEALT -> fail "variable is bound in a case alternative, not bound to an expression." CASEWILD e _ -> return e FORALL -> fail "variable is a universally quantified type variable." +hermitBindingSummary :: HermitBinding -> String +hermitBindingSummary b = show (hbDepth b) ++ "$" ++ case hbSite b of + LAM -> "LAM" + NONREC {} -> "NONREC" + REC {} -> "REC" + MUTUALREC {} -> "MUTUALREC" + SELFREC {} -> "SELFREC" + CASEALT -> "CASEALT" + CASEWILD {} -> "CASEWILD" + FORALL -> "FORALL" + -- | Retrieve the expression in a 'HermitBinding', if there is one. hermitBindingExpr :: HermitBinding -> KureM CoreExpr -hermitBindingExpr = hermitBindingSiteExpr . snd +hermitBindingExpr = hermitBindingSiteExpr . hbSite ------------------------------------------------------------------------ @@ -93,16 +113,19 @@ -- (Parallel bindings occur in recursive let bindings and case alternatives.) -- This can also be used for solitary bindings (e.g. lambdas). -- Bindings are added in parallel sets to help with shadowing issues. - addHermitBindings :: [(Var,HermitBindingSite)] -> c -> c + addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> c -> c -- | The bindings are just discarded. instance AddBindings (SnocPath crumb) where - addHermitBindings :: [(Var,HermitBindingSite)] -> SnocPath crumb -> SnocPath crumb + addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> SnocPath crumb -> SnocPath crumb addHermitBindings _ = id +instance ReadPath c Crumb => ReadPath (ExtendContext c e) Crumb where + absPath = absPath . baseContext + -- | The bindings are added to the base context and the extra context. instance (AddBindings c, AddBindings e) => AddBindings (ExtendContext c e) where - addHermitBindings :: [(Var,HermitBindingSite)] -> ExtendContext c e -> ExtendContext c e + addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> ExtendContext c e -> ExtendContext c e addHermitBindings bnds c = c { baseContext = addHermitBindings bnds (baseContext c) , extraContext = addHermitBindings bnds (extraContext c) @@ -110,43 +133,39 @@ ------------------------------------------- --- | Add a single binding to the context. -addHermitBinding :: AddBindings c => Var -> HermitBindingSite -> c -> c -addHermitBinding v bd = addHermitBindings [(v,bd)] - -- | Add all bindings in a binding group to a context. -addBindingGroup :: AddBindings c => CoreBind -> c -> c -addBindingGroup (NonRec v e) = addHermitBinding v (NONREC e) -addBindingGroup (Rec ies) = addHermitBindings [ (i, REC e) | (i,e) <- ies ] +addBindingGroup :: (AddBindings c, ReadPath c Crumb) => CoreBind -> c -> c +addBindingGroup (NonRec v e) c = addHermitBindings [(v,NONREC e,absPath c @@ Let_Bind)] c +addBindingGroup (Rec ies) c = addHermitBindings [ (i, REC e, absPath c @@ Let_Bind) | (i,e) <- ies ] c -- | Add the binding for a recursive definition currently under examination. -- Note that because the expression may later be modified, the context only records the identifier, not the expression. -addDefBinding :: AddBindings c => Id -> c -> c -addDefBinding i = addHermitBinding i SELFREC +addDefBinding :: (AddBindings c, ReadPath c Crumb) => Id -> c -> c +addDefBinding i c = addHermitBindings [(i,SELFREC,absPath c @@ Def_Id)] c -- | Add a list of recursive bindings to the context, except the nth binding in the list. -- The idea is to exclude the definition being descended into. -addDefBindingsExcept :: AddBindings c => Int -> [(Id,CoreExpr)] -> c -> c -addDefBindingsExcept n ies = addHermitBindings [ (i, REC e) | (m,(i,e)) <- zip [0..] ies, m /= n ] +addDefBindingsExcept :: (AddBindings c, ReadPath c Crumb) => Int -> [(Id,CoreExpr)] -> c -> c +addDefBindingsExcept n ies c = addHermitBindings [ (i, MUTUALREC e, absPath c @@ Rec_Def m) | (m,(i,e)) <- zip [0..] ies, m /= n ] c -- | Add a wildcard binding for a specific case alternative. -addCaseWildBinding :: AddBindings c => (Id,CoreExpr,CoreAlt) -> c -> c -addCaseWildBinding (i,e,(con,vs,_)) = addHermitBinding i (CASEWILD e (con,vs)) +addCaseWildBinding :: (AddBindings c, ReadPath c Crumb) => (Id,CoreExpr,CoreAlt) -> c -> c +addCaseWildBinding (i,e,(con,vs,_)) c = addHermitBindings [(i,CASEWILD e (con,vs),absPath c @@ Case_Binder)] c -- | 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 :: AddBindings c => Var -> c -> c -addLambdaBinding v = addHermitBinding v LAM +addLambdaBinding :: (AddBindings c, ReadPath c Crumb) => Var -> c -> c +addLambdaBinding v c = addHermitBindings [(v,LAM,absPath c @@ Lam_Var)] c -- | Add the variables bound by a 'DataCon' in a case. -- They are all bound at the same depth. -addAltBindings :: AddBindings c => [Var] -> c -> c -addAltBindings vs = addHermitBindings [ (v, CASEALT) | v <- vs ] +addAltBindings :: (AddBindings c, ReadPath c Crumb) => [Var] -> c -> c +addAltBindings vs c = addHermitBindings [ (v, CASEALT, absPath c @@ Alt_Var i) | (v,i) <- zip vs [1..] ] c -- | Add a universally quantified type variable to a context. -addForallBinding :: AddBindings c => TyVar -> c -> c -addForallBinding v = addHermitBinding v FORALL +addForallBinding :: (AddBindings c, ReadPath c Crumb) => TyVar -> c -> c +addForallBinding v c = addHermitBindings [(v,FORALL,absPath c @@ ForAllTy_Var)] c ------------------------------------------------------------------------ @@ -178,11 +197,11 @@ -- | Lookup the depth of a variable's binding in a context. lookupHermitBindingDepth :: (ReadBindings c, Monad m) => Var -> c -> m BindingDepth -lookupHermitBindingDepth v = liftM fst . lookupHermitBinding v +lookupHermitBindingDepth v = liftM hbDepth . lookupHermitBinding v -- | Lookup the binding for a variable in a context, ensuring it was bound at the specified depth. lookupHermitBindingSite :: (ReadBindings c, Monad m) => Var -> BindingDepth -> c -> m HermitBindingSite -lookupHermitBindingSite v depth c = do (d,bnd) <- lookupHermitBinding v c +lookupHermitBindingSite v depth c = do HB d bnd _ <- lookupHermitBinding v c guardMsg (d == depth) "lookupHermitBinding succeeded, but depth does not match. The variable has probably been shadowed." return bnd @@ -252,9 +271,9 @@ ------------------------------------------------------------------------ instance AddBindings HermitC where - addHermitBindings :: [(Var,HermitBindingSite)] -> HermitC -> HermitC + addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> HermitC -> HermitC addHermitBindings vbs c = let nextDepth = succ (hermitC_depth c) - vhbs = [ (v, (nextDepth,b)) | (v,b) <- vbs ] + vhbs = [ (v, HB nextDepth b p) | (v,b,p) <- vbs ] in c { hermitC_bindings = fromList vhbs `union` hermitC_bindings c , hermitC_depth = nextDepth } diff --git a/src/HERMIT/Core.hs b/src/HERMIT/Core.hs --- a/src/HERMIT/Core.hs +++ b/src/HERMIT/Core.hs @@ -46,6 +46,8 @@ , freeVarsDef , freeVarsExpr , freeVarsAlt + , freeVarsVar + , localFreeVarsAlt , freeVarsType , freeVarsCoercion , localFreeVarsExpr @@ -301,18 +303,26 @@ -- | Find all free identifiers in a binding group, which excludes any variables bound in the group. freeVarsBind :: CoreBind -> VarSet -freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` varTypeTyVars v +freeVarsBind (NonRec v e) = freeVarsExpr e `unionVarSet` freeVarsVar v freeVarsBind (Rec defs) = let (bs,es) = unzip defs in delVarSetList (unionVarSets $ map freeVarsExpr es) bs - `unionVarSet` unionVarSets (map varTypeTyVars bs) + `unionVarSet` unionVarSets (map freeVarsVar bs) --- | Find all free variables is a recursive definition, which excludes the bound variable. +-- | Find all free variables on a binder. Equivalent to idFreeVars, but safe to call on type bindings. +freeVarsVar :: Var -> VarSet +freeVarsVar v = varTypeTyVars v `unionVarSet` bndrRuleAndUnfoldingVars v + +-- | Find all free variables in a recursive definition, which excludes the bound variable. freeVarsDef :: CoreDef -> VarSet -freeVarsDef (Def v e) = delVarSet (freeVarsExpr e) v `unionVarSet` varTypeTyVars v +freeVarsDef (Def v e) = delVarSet (freeVarsExpr e) v `unionVarSet` freeVarsVar v -- | Find all free variables in a case alternative, which excludes any variables bound in the alternative. freeVarsAlt :: CoreAlt -> VarSet -freeVarsAlt (_,bs,e) = delVarSetList (freeVarsExpr e `unionVarSet` unionVarSets (map varTypeTyVars bs)) bs +freeVarsAlt (_,bs,e) = delVarSetList (freeVarsExpr e `unionVarSet` unionVarSets (map freeVarsVar bs)) bs + +-- | Find all free local variables in a case alternative, which excludes any variables bound in the alternative. +localFreeVarsAlt :: CoreAlt -> VarSet +localFreeVarsAlt (_,bs,e) = delVarSetList (localFreeVarsExpr e `unionVarSet` unionVarSets (map freeVarsVar bs)) bs -- | Find all free variables in a program. freeVarsProg :: CoreProg -> VarSet diff --git a/src/HERMIT/Dictionary/AlphaConversion.hs b/src/HERMIT/Dictionary/AlphaConversion.hs --- a/src/HERMIT/Dictionary/AlphaConversion.hs +++ b/src/HERMIT/Dictionary/AlphaConversion.hs @@ -135,7 +135,7 @@ -- | Rename local variables with manifestly unique names (x, x0, x1, ...). -- Does not rename top-level definitions. -unshadowR :: forall c. (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core +unshadowR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core unshadowR = setFailMsg "No shadows to eliminate." $ anytdR (promoteExprR unshadowExpr <+ promoteAltR unshadowAlt) @@ -156,7 +156,7 @@ -- | Replace all occurrences of a specified variable. -- Arguments are the variable to replace and the replacement variable, respectively. -replaceVarR :: (ExtendPath c Crumb, AddBindings c, Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a +replaceVarR :: (Injection a Core, MonadCatch m) => Var -> Var -> Rewrite c m a replaceVarR v v' = extractR $ tryR $ substR v $ varToCoreExpr v' -- | Given a variable to replace, and a replacement, produce a 'Var' @->@ 'Var' function that @@ -174,7 +174,7 @@ ----------------------------------------------------------------------- -- | Alpha rename a lambda binder. Optionally takes a suggested new name. -alphaLamR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr +alphaLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaLamR mn = setFailMsg (wrongFormForAlpha "Lam v e") $ do (v, nameModifier) <- lamT idR (freshNameGenT mn) (,) v' <- constT (cloneVarH nameModifier v) @@ -183,7 +183,7 @@ ----------------------------------------------------------------------- -- | Alpha rename a case binder. Optionally takes a suggested new name. -alphaCaseBinderR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr +alphaCaseBinderR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaCaseBinderR mn = setFailMsg (wrongFormForAlpha "Case e v ty alts") $ do Case _ v _ _ <- idR nameModifier <- freshNameGenT mn @@ -193,53 +193,55 @@ ----------------------------------------------------------------------- -- | Rename the specified variable in a case alternative. Optionally takes a suggested new name. -alphaAltVarR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt -alphaAltVarR mn v = - do nameModifier <- altT idR (\ _ -> idR) (freshNameGenT mn) (\ _ _ nameGen -> nameGen) - v' <- constT (cloneVarH nameModifier v) - altAnyR (fail "") (\ _ -> arr (replaceVar v v')) (replaceVarR v v') +alphaAltVarR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Var -> Rewrite c HermitM CoreAlt +alphaAltVarR mn v = do + nameModifier <- liftM (freshNameGenAvoiding mn) $ liftM2 unionVarSet boundVarsT (arr freeVarsAlt) + v' <- constT (cloneVarH nameModifier v) + -- Must replace the binder first, then substitution will work. + altAllR idR (\_ -> arr (replaceVar v v')) idR >>> substAltR v (varToCoreExpr v') -- | Rename the specified variables in a case alternative, using the suggested names where provided. -alphaAltVarsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt -alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) +-- Suggested names *must* be provided in left-to-right order matching the order of the alt binders. +alphaAltVarsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Var)] -> Rewrite c HermitM CoreAlt +alphaAltVarsWithR = andR . map (uncurry alphaAltVarR) . reverse -- note: right-to-left so type subst aren't undone -- | Rename the variables bound in a case alternative with the given list of suggested names. -alphaAltWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreAlt +alphaAltWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreAlt alphaAltWithR ns = do vs <- arr altVars alphaAltVarsWithR $ zip (map Just ns) vs -- | Rename the specified variables in a case alternative. -alphaAltVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt +alphaAltVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreAlt alphaAltVarsR vs = do bs <- arr altVars alphaAltVarsWithR (zip (repeat Nothing) (bs `intersect` vs)) -- | Rename all identifiers bound in a case alternative. -alphaAltR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt +alphaAltR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreAlt alphaAltR = arr altVars >>= alphaAltVarsR ----------------------------------------------------------------------- -- | Rename all identifiers bound in a case expression. -alphaCaseR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +alphaCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr alphaCaseR = alphaCaseBinderR Nothing >+> caseAllR idR idR idR (const alphaAltR) ----------------------------------------------------------------------- -- | Alpha rename a non-recursive let binder. Optionally takes a suggested new name. -alphaLetNonRecR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr +alphaLetNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Rewrite c HermitM CoreExpr alphaLetNonRecR mn = setFailMsg (wrongFormForAlpha "Let (NonRec v e1) e2") $ do (v, nameModifier) <- letNonRecT idR mempty (freshNameGenT mn) (\ v () nameMod -> (v, nameMod)) v' <- constT (cloneVarH nameModifier v) letNonRecAnyR (return v') idR (replaceVarR v v') -- | Alpha rename a non-recursive let binder if the variable appears in the argument list. Optionally takes a suggested new name. -alphaLetNonRecVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr +alphaLetNonRecVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> [Var] -> Rewrite c HermitM CoreExpr alphaLetNonRecVarsR mn vs = whenM ((`elem` vs) <$> letNonRecVarT) (alphaLetNonRecR mn) -- | Rename the specified identifier bound in a recursive let. Optionally takes a suggested new name. -alphaLetRecIdR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr +alphaLetRecIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Maybe TH.Name -> Id -> Rewrite c HermitM CoreExpr alphaLetRecIdR mn v = setFailMsg (wrongFormForAlpha "Let (Rec bs) e") $ do usedVars <- unionVarSet <$> boundVarsT <*> letRecT (\ _ -> defT idR (arr freeVarsExpr) (flip extendVarSet)) (arr freeVarsExpr) (\ bndfvs vs -> unionVarSets (vs:bndfvs)) @@ -247,29 +249,29 @@ letRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v') -- | Rename the specified identifiers in a recursive let, using the suggested names where provided. -alphaLetRecIdsWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr +alphaLetRecIdsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [(Maybe TH.Name,Id)] -> Rewrite c HermitM CoreExpr alphaLetRecIdsWithR = andR . map (uncurry alphaLetRecIdR) -- | Rename the identifiers bound in a Let with the given list of suggested names. -alphaLetWithR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr +alphaLetWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [TH.Name] -> Rewrite c HermitM CoreExpr alphaLetWithR ns = alphaLetNonRecR (listToMaybe ns) <+ (letRecIdsT >>= (alphaLetRecIdsWithR . zip (map Just ns))) -- | Rename the specified variables bound in a let. -alphaLetVarsR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr +alphaLetVarsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => [Var] -> Rewrite c HermitM CoreExpr alphaLetVarsR vs = alphaLetNonRecVarsR Nothing vs <+ (do bs <- letT (arr bindVars) successT const alphaLetRecIdsWithR (zip (repeat Nothing) (bs `intersect` vs)) ) -- | Rename all identifiers bound in a Let. -alphaLetR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +alphaLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr alphaLetR = letVarsT >>= alphaLetVarsR ----------------------------------------------------------------------- -- | Alpha rename a non-recursive top-level binder. Optionally takes a suggested new name. -alphaProgConsNonRecR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg +alphaProgConsNonRecR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => TH.Name -> Rewrite c HermitM CoreProg alphaProgConsNonRecR n = setFailMsg (wrongFormForAlpha "ProgCons (NonRec v e) p") $ do ProgCons (NonRec v _) _ <- idR v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v) @@ -280,17 +282,17 @@ -- alphaConsNonRecIds mn vs = whenM ((`elem` vs) <$> consNonRecIdT) (alphaConsNonRec mn) -- | Rename the specified identifier bound in a recursive top-level binder. Optionally takes a suggested new name. -alphaProgConsRecIdR :: (ExtendPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg +alphaProgConsRecIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => TH.Name -> Id -> Rewrite c HermitM CoreProg alphaProgConsRecIdR n v = setFailMsg (wrongFormForAlpha "ProgCons (Rec bs) p") $ do v' <- constT (cloneVarH (\ _ -> TH.nameBase n) v) consRecDefAnyR (\ _ -> (arr (replaceVar v v'), replaceVarR v v')) (replaceVarR v v') -- | Rename the specified identifiers in a recursive top-level binding at the head of a program, using the suggested names where provided. -alphaProgConsRecIdsWithR :: (ExtendPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg +alphaProgConsRecIdsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [(TH.Name,Id)] -> Rewrite c HermitM CoreProg alphaProgConsRecIdsWithR = andR . map (uncurry alphaProgConsRecIdR) -- | Rename the identifiers bound in the top-level binding at the head of the program with the given list of suggested names. -alphaProgConsWithR :: (ExtendPath c Crumb, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg +alphaProgConsWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [TH.Name] -> Rewrite c HermitM CoreProg alphaProgConsWithR [] = fail "At least one new name must be provided." alphaProgConsWithR (n:ns) = alphaProgConsNonRecR n <+ (progConsRecIdsT >>= (alphaProgConsRecIdsWithR . zip (n:ns))) @@ -311,7 +313,7 @@ ----------------------------------------------------------------------- -- | Alpha rename any bindings at this node. Note: does not rename case alternatives unless invoked on the alternative. -alphaR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core +alphaR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM Core alphaR = setFailMsg "Cannot alpha-rename here." $ promoteExprR (alphaLamR Nothing <+ alphaCaseBinderR Nothing <+ alphaLetR) <+ promoteAltR alphaAltR diff --git a/src/HERMIT/Dictionary/Common.hs b/src/HERMIT/Dictionary/Common.hs --- a/src/HERMIT/Dictionary/Common.hs +++ b/src/HERMIT/Dictionary/Common.hs @@ -113,26 +113,26 @@ return res -- | Apply a rewrite to all applications of a given function in a top-down manner, pruning on success. -callsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr -> Rewrite c m Core +callsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr -> Rewrite c m Core callsR nm rr = prunetdR (promoteExprR $ callNameG nm >> rr) -- | Apply a translate to all applications of a given function in a top-down manner, -- pruning on success, collecting the results. -callsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Translate c m CoreExpr b -> Translate c m Core [b] +callsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => TH.Name -> Translate c m CoreExpr b -> Translate c m Core [b] callsT nm t = collectPruneT (promoteExprT $ callNameG nm >> t) ------------------------------------------------------------------------------ -- | List the identifiers bound by the top-level binding group at the head of the program. -progConsIdsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id] +progConsIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreProg [Id] progConsIdsT = progConsT (arr bindVars) mempty (\ vs () -> vs) -- | List the identifiers bound by a recursive top-level binding group at the head of the program. -progConsRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id] +progConsRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg [Id] progConsRecIdsT = progConsT recIdsT mempty (\ vs () -> vs) -- | Return the identifier bound by a non-recursive top-level binding at the head of the program. -progConsNonRecIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id +progConsNonRecIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreProg Id progConsNonRecIdT = progConsT nonRecVarT mempty (\ v () -> v) -- | Return the variable bound by a non-recursive let expression. @@ -140,35 +140,35 @@ nonRecVarT = nonRecT idR mempty (\ v () -> v) -- | List all identifiers bound in a recursive binding group. -recIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id] +recIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind [Id] recIdsT = recT (\ _ -> arr defId) id -- | Return the variable bound by a lambda expression. -lamVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var +lamVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var lamVarT = lamT idR mempty (\ v () -> v) -- | List the variables bound by a let expression. -letVarsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var] +letVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreExpr [Var] letVarsT = letT (arr bindVars) mempty (\ vs () -> vs) -- | List the identifiers bound by a recursive let expression. -letRecIdsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id] +letRecIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Id] letRecIdsT = letT recIdsT mempty (\ vs () -> vs) -- | Return the variable bound by a non-recursive let expression. -letNonRecVarT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var +letNonRecVarT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Var letNonRecVarT = letT nonRecVarT mempty (\ v () -> v) -- | List all variables bound by a case expression (in the alternatives and the wildcard binder). -caseVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var] +caseVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [Var] caseVarsT = caseT mempty idR mempty (\ _ -> arr altVars) (\ () v () vss -> v : nub (concat vss)) -- | Return the case wildcard binder. -caseWildIdT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id +caseWildIdT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr Id caseWildIdT = caseT mempty idR mempty (\ _ -> idR) (\ () i () _ -> i) -- | List the variables bound by all alternatives in a case expression. -caseAltVarsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]] +caseAltVarsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr [[Var]] caseAltVarsT = caseT mempty mempty mempty (\ _ -> arr altVars) (\ () () () vss -> vss) ------------------------------------------------------------------------------ diff --git a/src/HERMIT/Dictionary/Composite.hs b/src/HERMIT/Dictionary/Composite.hs --- a/src/HERMIT/Dictionary/Composite.hs +++ b/src/HERMIT/Dictionary/Composite.hs @@ -53,11 +53,11 @@ -- | Unfold the current expression if it is one of the basic combinators: ('$'), ('.'), 'id', 'flip', 'const', 'fst' or 'snd'. -- This is intended to be used as a component of simplification traversals such as 'simplifyR' or 'bashR'. -unfoldBasicCombinatorR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +unfoldBasicCombinatorR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr unfoldBasicCombinatorR = setFailMsg "unfold-basic-combinator failed." $ unfoldNamesR (map TH.mkName basicCombinators) -simplifyR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core +simplifyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core simplifyR = setFailMsg "Simplify failed: nothing to simplify." $ innermostR ( promoteBindR recToNonrecR <+ promoteExprR ( unfoldBasicCombinatorR @@ -69,10 +69,10 @@ ------------------------------------------------------------------------------------------------------ -bashR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core +bashR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM Core bashR = bashUsingR (map fst bashComponents) -bashExtendedWithR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core +bashExtendedWithR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [Rewrite c HermitM Core] -> Rewrite c HermitM Core bashExtendedWithR rs = bashUsingR (rs ++ map fst bashComponents) bashDebugR :: RewriteH Core @@ -90,7 +90,7 @@ -- bashCoreR :: Rewrite c m Core -- bashCoreR = repeatR (innermostR (catchesT rs) >>> occurAnalyseR) -bashUsingR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core +bashUsingR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => [Rewrite c m Core] -> Rewrite c m Core bashUsingR rs = setFailMsg "bash failed: nothing to do." $ repeatR (occurAnalyseR >>> onetdR (catchesT rs)) >+> anytdR (promoteExprR dezombifyR) >+> occurAnalyseChangedR @@ -115,7 +115,7 @@ ) -- TODO: Think about a good order for bash. -bashComponents :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)] +bashComponents :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [(Rewrite c HermitM Core, String)] bashComponents = [ -- (promoteExprR occurAnalyseExprChangedR, "occur-analyse-expr") -- ?? (promoteExprR betaReduceR, "beta-reduce") -- O(1) diff --git a/src/HERMIT/Dictionary/Fold.hs b/src/HERMIT/Dictionary/Fold.hs --- a/src/HERMIT/Dictionary/Fold.hs +++ b/src/HERMIT/Dictionary/Fold.hs @@ -132,7 +132,9 @@ foldMatch vs as (Var i) e | i `elem` vs = return [(i,e)] | otherwise = case e of Var i' | maybe False (==i) (lookup i' as) -> return [(i,e)] - | i == i' -> return [] + -- TODO: type comparison here is a total hack, + -- see notes in hermit-syb + | i == i' && eqType (idType i) (idType i') -> return [] _ -> Nothing foldMatch _ _ (Lit l) (Lit l') | l == l' = return [] foldMatch vs as (App e a) (App e' a') = do diff --git a/src/HERMIT/Dictionary/Function.hs b/src/HERMIT/Dictionary/Function.hs --- a/src/HERMIT/Dictionary/Function.hs +++ b/src/HERMIT/Dictionary/Function.hs @@ -34,15 +34,15 @@ ------------------------------------------------------------------------------------------------------ -- | Traditional Static Argument Transformation -staticArgR :: (ExtendPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef +staticArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef staticArgR = staticArgPredR (return . map fst) -- | Static Argument Transformation that only considers type arguments to be static. -staticArgTypesR :: (ExtendPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef +staticArgTypesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Rewrite c HermitM CoreDef staticArgTypesR = staticArgPredR (return . map fst . filter (isTyVar . snd)) -- | Static Argument Transformations which requires that arguments in the given position are static. -staticArgPosR :: (ExtendPath c Crumb, AddBindings c) => [Int] -> Rewrite c HermitM CoreDef +staticArgPosR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [Int] -> Rewrite c HermitM CoreDef staticArgPosR is' = staticArgPredR $ \ss' -> let is = nub is' ss = map fst ss' in if is == (is `intersect` ss) @@ -50,7 +50,7 @@ else fail $ "args " ++ commas (filter (`notElem` ss) is) ++ " are not static." -- | Generalized Static Argument Transformation, which allows static arguments to be filtered. -staticArgPredR :: (ExtendPath c Crumb, AddBindings c) +staticArgPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => ([(Int, Var)] -> HermitM [Int]) -- ^ given list of static args and positions, decided which to transform -> Rewrite c HermitM CoreDef staticArgPredR decide = prefixFailMsg "static-arg failed: " $ do diff --git a/src/HERMIT/Dictionary/GHC.hs b/src/HERMIT/Dictionary/GHC.hs --- a/src/HERMIT/Dictionary/GHC.hs +++ b/src/HERMIT/Dictionary/GHC.hs @@ -6,7 +6,8 @@ , anyCallR -- ** Substitution , substR - , substExprR + , substAltR + , substCoreExpr -- ** Utilities , inScope , rule @@ -30,6 +31,7 @@ import qualified CoreLint import IOEnv hiding (liftIO) import qualified SpecConstr +import qualified Specialise import Control.Arrow import Control.Monad @@ -45,6 +47,7 @@ import HERMIT.GHC import HERMIT.Dictionary.Debug hiding (externals) +import HERMIT.Dictionary.Kure (unitT) import qualified Language.Haskell.TH as TH @@ -77,6 +80,8 @@ [ "Runs GHC's Core Lint, which typechecks the current module."] .+ Deep .+ Debug .+ Query , external "spec-constr" (promoteModGutsR specConstrR :: RewriteH Core) [ "Run GHC's SpecConstr pass, which performs call pattern specialization."] .+ Deep + , external "specialise" (promoteModGutsR specialise :: RewriteH Core) + [ "Run GHC's specialisation pass, which performs type and dictionary specialization."] .+ Deep , external "any-call" (anyCallR :: RewriteH Core -> RewriteH Core) [ "any-call (.. unfold command ..) applies an unfold command to all applications." , "Preference is given to applications with more arguments." ] .+ Deep @@ -85,19 +90,19 @@ ------------------------------------------------------------------------ -- | Substitute all occurrences of a variable with an expression, in either a program or an expression. -substR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Var -> CoreExpr -> Rewrite c m Core -substR v e = setFailMsg "Can only perform substitution on expressions or programs." $ - promoteExprR (substExprR v e) <+ promoteProgR (substTopBindR v e) <+ promoteAltR (substAltR v e) +substR :: MonadCatch m => Var -> CoreExpr -> Rewrite c m Core +substR v e = setFailMsg "Can only perform substitution on expressions, case alternatives or programs." $ + promoteExprR (arr $ substCoreExpr v e) <+ promoteProgR (substTopBindR v e) <+ promoteAltR (substAltR v e) -- | Substitute all occurrences of a variable with an expression, in an expression. -substExprR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreExpr -substExprR v e = contextfreeT $ \ expr -> do +substCoreExpr :: Var -> CoreExpr -> (CoreExpr -> CoreExpr) +substCoreExpr v e 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 (localFreeVarsExpr (Let (NonRec v e) expr))) - return $ substExpr (text "substR") (extendSubst emptySub v e) expr + in substExpr (text "substCoreExpr") (extendSubst emptySub v e) expr -- | Substitute all occurrences of a variable with an expression, in a program. substTopBindR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreProg @@ -107,17 +112,12 @@ return $ bindsToProg $ snd (mapAccumL substBind (extendSubst emptySub v e) (progToBinds p)) -- | Substitute all occurrences of a variable with an expression, in a case alternative. -substAltR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Var -> CoreExpr -> Rewrite c m CoreAlt -substAltR v e = do (_, vs, _) <- idR - if v `elem` vs - then fail "variable is shadowed by a case-alternative constructor argument." - else altAllR idR (\ _ -> idR) (substExprR v e) - --- Neil: Commented this out as it's not (currently) used. --- Perform let-substitution the specified number of times. --- letSubstNR :: Int -> Rewrite c m Core --- letSubstNR 0 = idR --- letSubstNR n = childR 1 (letSubstNR (n - 1)) >>> promoteExprR letSubstR +substAltR :: Monad m => Var -> CoreExpr -> Rewrite c m CoreAlt +substAltR v e = do + (inS, (c, vs, rhs)) <- arr (flip delVarSet v . unionVarSet (localFreeVarsExpr e) . localFreeVarsAlt) &&& idR + let subst = extendSubst (mkEmptySubst (mkInScopeSet inS)) v e + (subst', vs') = substBndrs subst vs + return (c, vs', substExpr (text "alt-rhs") subst' rhs) ------------------------------------------------------------------------ @@ -291,14 +291,34 @@ $ CoreLint.lintUnfolding noSrcLoc (varSetElems $ boundVars c) e #endif +-- | Run GHC's specConstr pass, and apply any rules generated. specConstrR :: RewriteH ModGuts -specConstrR = do +specConstrR = prefixFailMsg "spec-constr failed: " $ do rs <- extractT specRules e' <- contextfreeT $ liftCoreM . SpecConstr.specConstrProgram rs' <- return e' >>> extractT specRules let specRs = deleteFirstsBy ((==) `on` ru_name) rs' rs + guardMsg (notNull specRs) "no rules created." return e' >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs))) +-- | Run GHC's specialisation pass, and apply any rules generated. +specialise :: RewriteH ModGuts +specialise = prefixFailMsg "specialisation failed: " $ do + gRules <- arr mg_rules + lRules <- extractT specRules + + dflags <- dynFlagsT + guts <- contextfreeT $ liftCoreM . Specialise.specProgram dflags + + lRules' <- return guts >>> extractT specRules -- spec rules on bindings in this module + let gRules' = mg_rules guts -- plus spec rules on imported bindings + gSpecRs = deleteFirstsBy ((==) `on` ru_name) gRules' gRules + lSpecRs = deleteFirstsBy ((==) `on` ru_name) lRules' lRules + specRs = gSpecRs ++ lSpecRs + guardMsg (notNull specRs) "no rules created." + liftIO $ putStrLn $ unlines $ map (unpackFS . ru_name) specRs + return guts >>> extractR (repeatR (anyCallR (promoteExprR $ rulesToRewriteH specRs))) + -- | Get all the specialization rules on a binding. -- These are created by SpecConstr and other GHC passes. idSpecRules :: TranslateH Id [CoreRule] @@ -306,8 +326,8 @@ -- | Promote 'idSpecRules' to CoreBind. bindSpecRules :: TranslateH CoreBind [CoreRule] -bindSpecRules = recT (\_ -> defT idSpecRules (return ()) const) concat - <+ nonRecT idSpecRules (return ()) const +bindSpecRules = recT (\_ -> defT idSpecRules unitT const) concat + <+ nonRecT idSpecRules unitT const -- | Find all specialization rules in a Core fragment. specRules :: TranslateH Core [CoreRule] @@ -342,7 +362,7 @@ dezombifyR = varR (acceptR isDeadBinder >>^ zapVarOccInfo) -- | Apply 'occurAnalyseExprR' to all sub-expressions. -occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core +occurAnalyseR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurAnalyseR = let r = promoteExprR (arr occurAnalyseExpr) go = r <+ anyR go in tryR go -- always succeed @@ -352,14 +372,14 @@ occurAnalyseExprChangedR = changedByR exprSyntaxEq (arr occurAnalyseExpr) -- | Occurrence analyse all sub-expressions, failing if the result is syntactically equal to the initial expression. -occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core +occurAnalyseChangedR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurAnalyseChangedR = changedByR coreSyntaxEq occurAnalyseR -- | Run GHC's occurrence analyser, and also eliminate any zombies. -occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core +occurAnalyseAndDezombifyR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurAnalyseAndDezombifyR = allbuR (tryR $ promoteExprR dezombifyR) >>> occurAnalyseR -occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m Core +occurrenceAnalysisR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m Core occurrenceAnalysisR = occurAnalyseAndDezombifyR {- Does not work (no export) diff --git a/src/HERMIT/Dictionary/Inline.hs b/src/HERMIT/Dictionary/Inline.hs --- a/src/HERMIT/Dictionary/Inline.hs +++ b/src/HERMIT/Dictionary/Inline.hs @@ -60,30 +60,30 @@ data InlineConfig = CaseBinderOnly CaseBinderInlineOption | AllBinders deriving (Eq, Show) -- | If the current variable matches the given name, then inline it. -inlineNameR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr +inlineNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr inlineNameR nm = configurableInlineR AllBinders (arr $ cmpTHName2Var nm) -- | If the current variable matches any of the given names, then inline it. -inlineNamesR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr +inlineNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr inlineNamesR [] = fail "inline-names failed: no names given." inlineNamesR nms = configurableInlineR AllBinders (arr $ \ v -> any (flip cmpTHName2Var v) nms) -- | Inline the current variable. -inlineR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +inlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr inlineR = configurableInlineR AllBinders (return True) -- | Inline the current identifier if it is a case binder, using the scrutinee rather than the case-alternative pattern. -inlineCaseScrutineeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +inlineCaseScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr inlineCaseScrutineeR = configurableInlineR (CaseBinderOnly Scrutinee) (return True) -- | Inline the current identifier if is a case binder, using the case-alternative pattern rather than the scrutinee. -inlineCaseAlternativeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +inlineCaseAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr inlineCaseAlternativeR = configurableInlineR (CaseBinderOnly Alternative) (return True) -- | The implementation of inline, an important transformation. -- This *only* works if the current expression has the form @Var v@ (it does not traverse the expression). -- It can trivially be prompted to more general cases using traversal strategies. -configurableInlineR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) +configurableInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => InlineConfig -> (Translate c HermitM Id Bool) -- ^ Only inline identifiers that satisfy this predicate. -> Rewrite c HermitM CoreExpr @@ -99,22 +99,23 @@ -- NOTE: When inlining, we have to take care to avoid variable capture. -- Our approach is to track the binding depth of the inlined identifier. -- After inlining, we then resolve all names in the inlined expression, and require that they were all bound prior to (i.e. lower numbered depth) the binding we inlined. --- The precise depth check varies between binding types as follows (where d is the depth of the inlined binder): +-- The precise depth check varies between binding sites as follows (where d is the depth of the inlined binder): -- --- Binder Safe to Inline +-- Binding Site Safe to Inline -- global-id (<= 0) --- letnonrec (< d) --- letrec (<= d) --- case-wild-scrutinee (< d) --- case-wild-alt (<= d+1) --- self-rec-def NA --- lam NA --- case-alt NA +-- NONREC (< d) +-- REC (<= d) +-- MUTUALREC (<= d+1) +-- CASEWILD-scrutinee (< d) +-- CASEWILD-alt (<= d+1) +-- SELFREC-def NA +-- LAM NA +-- CASEALT NA -- | Ensure all the free variables in an expression were bound above a given depth. -- Assumes minimum depth is 0. -ensureDepthT :: forall c m. (ExtendPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m) => (BindingDepth -> Bool) -> Translate c m CoreExpr Bool +ensureDepthT :: forall c m. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, MonadCatch m) => (BindingDepth -> Bool) -> Translate c m CoreExpr Bool ensureDepthT uncaptured = do frees <- arr localFreeVarsExpr let collectDepthsT :: Translate c m Core [BindingDepth] @@ -137,7 +138,8 @@ DFunUnfolding _arity dc args -> (,uncaptured) <$> dFunExpr dc args (idType i) #endif _ -> fail $ "cannot find unfolding in Env or IdInfo." - Just (depth,b) -> case b of + Just b -> let depth = hbDepth b + in case hbSite b of CASEWILD s alt -> let tys = tyConAppArgs (idType i) altExprDepthM = (, (<= depth+1)) <$> alt2Exp tys alt scrutExprDepthM = return (s, (< depth)) @@ -152,6 +154,9 @@ REC e -> do requireAllBinders config return (e, (<= depth)) + MUTUALREC e -> do requireAllBinders config + return (e, (<= depth+1)) + _ -> fail "variable is not bound to an expression." where requireAllBinders :: Monad m => InlineConfig -> m () @@ -174,7 +179,7 @@ alt2Exp tys (DataAlt dc, vs) = return $ mkCoreConApps dc (map Type tys ++ map (varToCoreExpr . zapVarOccInfo) vs) -- | Get list of possible inline targets. Used by shell for completion. -inlineTargetsT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Translate c HermitM Core [String] +inlineTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Translate c HermitM Core [String] inlineTargetsT = collectT $ promoteT $ whenM (testM inlineR) (varT $ arr var2String) -- | Build a CoreExpr for a DFunUnfolding diff --git a/src/HERMIT/Dictionary/Kure.hs b/src/HERMIT/Dictionary/Kure.hs --- a/src/HERMIT/Dictionary/Kure.hs +++ b/src/HERMIT/Dictionary/Kure.hs @@ -3,6 +3,7 @@ module HERMIT.Dictionary.Kure ( -- * KURE Strategies externals + , unitT ) where @@ -21,6 +22,8 @@ externals = map (.+ KURE) [ external "id" (idR :: RewriteH Core) [ "Perform an identity rewrite."] .+ Shallow + , external "unit" (unitT :: TranslateH Core ()) + [ "An always succeeding translation to ()." ] , external "fail" (fail :: String -> RewriteH Core) [ "A failing rewrite."] , external "<+" ((<+) :: RewriteH Core -> RewriteH Core -> RewriteH Core) @@ -113,3 +116,7 @@ {-# INLINE testQuery #-} ------------------------------------------------------------------------------------ + +unitT :: Monad m => Translate c m a () +unitT = return () +{-# INLINE unitT #-} diff --git a/src/HERMIT/Dictionary/Local.hs b/src/HERMIT/Dictionary/Local.hs --- a/src/HERMIT/Dictionary/Local.hs +++ b/src/HERMIT/Dictionary/Local.hs @@ -35,6 +35,7 @@ import HERMIT.Utilities import HERMIT.Dictionary.Common +import HERMIT.Dictionary.GHC (substCoreExpr) import HERMIT.Dictionary.Local.Bind hiding (externals) import qualified HERMIT.Dictionary.Local.Bind as Bind import HERMIT.Dictionary.Local.Case hiding (externals) @@ -175,7 +176,7 @@ Nothing -> fail "type of expression is not a function or a forall." -- | Perform multiple eta-expansions. -multiEtaExpandR :: (ExtendPath c Crumb, AddBindings c) => [String] -> Rewrite c HermitM CoreExpr +multiEtaExpandR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => [String] -> Rewrite c HermitM CoreExpr multiEtaExpandR [] = idR multiEtaExpandR (nm:nms) = etaExpandR nm >>> lamAllR idR (multiEtaExpandR nms) @@ -200,11 +201,12 @@ -- | Abstract over a variable using a lambda. -- e ==> (\ x. e) x -abstractR :: (ReadBindings c, MonadCatch m) => TH.Name -> Rewrite c m CoreExpr +abstractR :: (ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr abstractR nm = prefixFailMsg "abstraction failed: " $ - do e <- idR - v <- findBoundVarT nm - return (App (Lam v e) (varToCoreExpr v)) + do v <- findBoundVarT nm + v' <- constT (cloneVarH id v) -- currently uses the same visible name (via "id"). We could do something else here, e.g. add a prime suffix. + e <- arr (substCoreExpr v (varToCoreExpr v')) + return $ App (Lam v' e) (varToCoreExpr v) ------------------------------------------------------------------------------------------------------ @@ -215,7 +217,7 @@ -- | Push a function through a Case or Let expression. -- Unsafe if the function is not strict. -pushR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) +pushR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) => Maybe (Rewrite c HermitM CoreExpr) -- ^ a proof that the function (after being applied to its type arguments) is strict -> (Id -> Bool) -- ^ a predicate to identify the function -> Rewrite c HermitM CoreExpr diff --git a/src/HERMIT/Dictionary/Local/Case.hs b/src/HERMIT/Dictionary/Local/Case.hs --- a/src/HERMIT/Dictionary/Local/Case.hs +++ b/src/HERMIT/Dictionary/Local/Case.hs @@ -9,9 +9,9 @@ , caseFloatCastR , caseFloatLetR , caseFloatR - , caseUnfloatR - , caseUnfloatAppR - , caseUnfloatArgsR + , caseFloatInR + , caseFloatInAppR + , caseFloatInArgsR , caseReduceR , caseReduceDataconR , caseReduceLiteralR @@ -76,12 +76,12 @@ [ "let v = case ec of alt1 -> e1 in e ==> case ec of alt1 -> let v = e1 in e" ] .+ Commute .+ Shallow , external "case-float" (promoteExprR caseFloatR :: RewriteH Core) [ "case-float = case-float-app <+ case-float-case <+ case-float-let <+ case-float-cast" ] .+ Commute .+ Shallow - , external "case-unfloat" (promoteExprR caseUnfloatR :: RewriteH Core) - [ "Unfloat a Case whatever the context." ] .+ Commute .+ Shallow .+ PreCondition - , external "case-unfloat-args" (promoteExprR caseUnfloatArgsR :: RewriteH Core) - [ "Unfloat a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition - -- , external "case-unfloat-app" (promoteExprR caseUnfloatApp :: RewriteH Core) - -- [ "Unfloat a Case whole alternatives are applications of different functions with the same arguments." ] .+ Commute .+ Shallow .+ PreCondition + , external "case-float-in" (promoteExprR caseFloatInR :: RewriteH Core) + [ "Float in a Case whatever the context." ] .+ Commute .+ Shallow .+ PreCondition + , external "case-float-in-args" (promoteExprR caseFloatInArgsR :: RewriteH Core) + [ "Float in a Case whose alternatives are parallel applications of the same function." ] .+ Commute .+ Shallow .+ PreCondition + -- , external "case-float-in-app" (promoteExprR caseFloatInApp :: RewriteH Core) + -- [ "Float in a Case whose alternatives are applications of different functions with the same arguments." ] .+ Commute .+ Shallow .+ PreCondition , external "case-reduce" (promoteExprR caseReduceR :: RewriteH Core) [ "Case of Known Constructor" , "case-reduce-datacon <+ case-reduce-literal" ] .+ Shallow .+ Eval @@ -142,7 +142,7 @@ ------------------------------------------------------------------------------ -- | (case s of alt1 -> e1; alt2 -> e2) v ==> case s of alt1 -> e1 v; alt2 -> e2 v -caseFloatAppR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatAppR = prefixFailMsg "Case floating from App function failed: " $ do captures <- appT (map mkVarSet <$> caseAltVarsT) (arr freeVarsExpr) (flip (map . intersectVarSet)) @@ -162,7 +162,7 @@ -- | @f (case s of alt1 -> e1; alt2 -> e2)@ ==> @case s of alt1 -> f e1; alt2 -> f e2@ -- Only safe if @f@ is strict. -caseFloatArgR :: (ExtendPath c Crumb, AddBindings c, BoundVars c, HasGlobalRdrEnv c) +caseFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c, HasGlobalRdrEnv c) => Maybe (CoreExpr, Maybe (Rewrite c HermitM CoreExpr)) -- ^ Maybe the function to float past, and maybe a proof of its strictness. -> Rewrite c HermitM CoreExpr caseFloatArgR mfstrict = prefixFailMsg "Case floating from App argument failed: " $ @@ -191,7 +191,7 @@ -- case s1 of -- alt11 -> case e11 of alt21 -> e21; alt22 -> e22 -- alt12 -> case e12 of alt21 -> e21; alt22 -> e22 -caseFloatCaseR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatCaseR = prefixFailMsg "Case floating from Case failed: " $ do captures <- caseT (map mkVarSet <$> caseAltVarsT) idR mempty (const $ arr freeVarsAlt) (\ vss w () fvs -> map (intersectVarSet (delVarSet (unionVarSets fvs) w)) vss) @@ -206,7 +206,7 @@ (\ (Case s1 b1 _ alts1) b2 ty alts2 -> Case s1 b1 ty $ mapAlts (\s -> Case s b2 ty alts2) alts1) -- | let v = case s of alt1 -> e1 in e ==> case s of alt1 -> let v = e1 in e -caseFloatLetR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatLetR = prefixFailMsg "Case floating from Let failed: " $ do vs <- letNonRecT idR caseAltVarsT mempty (\ letVar caseVars () -> letVar `elem` concat caseVars) let bdsAction = if not vs then idR else nonRecAllR idR alphaCaseR @@ -223,23 +223,23 @@ -- | caseFloatR = caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR -- Note: does NOT include caseFloatArg -caseFloatR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFloatR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFloatR = setFailMsg "Unsuitable expression for Case floating." $ caseFloatAppR <+ caseFloatCaseR <+ caseFloatLetR <+ caseFloatCastR ------------------------------------------------------------------------------ --- | Unfloat a Case whatever the context. -caseUnfloatR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -caseUnfloatR = setFailMsg "Case unfloating failed." $ - caseUnfloatAppR <+ caseUnfloatArgsR +-- | Float in a Case whatever the context. +caseFloatInR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr +caseFloatInR = setFailMsg "Case floating in failed." $ + caseFloatInAppR <+ caseFloatInArgsR -- | Unimplemented! -caseUnfloatAppR :: Monad m => Rewrite c m CoreExpr -caseUnfloatAppR = fail "caseUnfloatApp: TODO" +caseFloatInAppR :: Monad m => Rewrite c m CoreExpr +caseFloatInAppR = fail "caseFloatInApp: TODO" -caseUnfloatArgsR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -caseUnfloatArgsR = prefixFailMsg "Case unfloating into arguments failed: " $ +caseFloatInArgsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr +caseFloatInArgsR = prefixFailMsg "Case floating into arguments failed: " $ withPatFailMsg (wrongExprForm "Case s v t alts") $ do Case s wild _ty alts <- idR (vss, fs, argss) <- caseT mempty mempty mempty (\ _ -> altT mempty (\ _ -> idR) callT $ \ () vs (fn, args) -> (vs, fn, args)) @@ -260,12 +260,12 @@ ------------------------------------------------------------------------------ -- | Inline the case scrutinee (if it is an identifier), and then perform case reduction. -caseReduceIdR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseReduceIdR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseReduceIdR = caseAllR inlineR idR idR (const idR) >>> caseReduceR -- | Case of Known Constructor. -- Eliminate a case if the scrutinee is a data constructor or a literal. -caseReduceR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseReduceR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseReduceR = setFailMsg "Unsuitable expression for Case reduction." $ caseReduceDataconR <+ caseReduceLiteralR @@ -290,7 +290,7 @@ -- | Case of Known Constructor. -- Eliminate a case if the scrutinee is a data constructor. -caseReduceDataconR :: forall c. (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseReduceDataconR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseReduceDataconR = prefixFailMsg "Case reduction failed: " $ withPatFailMsg (wrongExprForm "Case e v t alts") go @@ -358,12 +358,12 @@ -- for each occurance of the named variable. -- -- > caseSplitInline nm = caseSplit nm >>> anybuR (inlineName nm) -caseSplitInlineR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM Core +caseSplitInlineR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM Core caseSplitInlineR nm = promoteR (caseSplitR nm) >>> anybuR (promoteExprR $ inlineNameR nm) ------------------------------------------------------------------------------ -caseInlineBinderR :: forall c. (ExtendPath c Crumb, AddBindings c, ReadBindings c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr +caseInlineBinderR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => CaseBinderInlineOption -> Rewrite c HermitM CoreExpr caseInlineBinderR opt = do w <- caseWildIdT caseAllR idR idR idR $ \ _ -> setFailMsg "no inlinable occurrences." $ @@ -371,12 +371,12 @@ extractR $ anybuR (promoteExprR (configurableInlineR (CaseBinderOnly opt) (varIsOccurrenceOfT w depth)) :: Rewrite c HermitM Core) -- | Inline the case wildcard binder as the case scrutinee everywhere in the case alternatives. -caseInlineScrutineeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseInlineScrutineeR = prefixFailMsg "case-inline-scrutinee failed: " $ caseInlineBinderR Scrutinee -- | Inline the case wildcard binder as the case-alternative pattern everywhere in the case alternatives. -caseInlineAlternativeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseInlineAlternativeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseInlineAlternativeR = prefixFailMsg "case-inline-alternative failed: " $ caseInlineBinderR Alternative @@ -396,30 +396,30 @@ return $ Case e w ty [(DEFAULT,[],head rhss)] -- | In the case alternatives, fold any occurrences of the case alt patterns to the wildcard binder. -caseFoldWildR :: forall c. (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseFoldWildR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseFoldWildR = prefixFailMsg "case-fold-wild failed: " $ do w <- caseWildIdT caseAllR idR idR idR $ \ _ -> do depth <- varBindingDepthT w extractR $ anybuR (promoteExprR (foldVarR w (Just depth)) :: Rewrite c HermitM Core) -- | A cleverer version of 'mergeCaseAlts' that first attempts to abstract out any occurrences of the alternative pattern using the wildcard binder. -caseMergeAltsWithWildR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseMergeAltsWithWildR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseMergeAltsWithWildR = prefixFailMsg "merge-case-alts-with-wild failed: " $ withPatFailMsg (wrongExprForm "Case e w ty alts") $ tryR caseFoldWildR >>> caseMergeAltsR -- | Eliminate a case, inlining any occurrences of the case binder as the scrutinee. -caseElimInlineScrutineeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseElimInlineScrutineeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseElimInlineScrutineeR = alphaCaseBinderR Nothing >>> tryR caseInlineScrutineeR >>> caseElimR -- | Eliminate a case, merging the case alternatives into a single default alternative and inlining the case binder as the scrutinee (if possible). -caseElimMergeAltsR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseElimMergeAltsR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseElimMergeAltsR = tryR caseFoldWildR >>> tryR caseMergeAltsR >>> caseElimInlineScrutineeR ------------------------------------------------------------------------------ -- | Eliminate a case that corresponds to a pointless 'seq'. -caseElimSeqR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +caseElimSeqR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr caseElimSeqR = prefixFailMsg "case-elim-seq failed: " $ withPatFailMsg "not a seq case." $ do Case s w _ [(DEFAULT,[],rhs)] <- idR diff --git a/src/HERMIT/Dictionary/Local/Let.hs b/src/HERMIT/Dictionary/Local/Let.hs --- a/src/HERMIT/Dictionary/Local/Let.hs +++ b/src/HERMIT/Dictionary/Local/Let.hs @@ -11,9 +11,12 @@ , letElimR , letNonRecElimR , letRecElimR + , progBindElimR + , progBindNonRecElimR + , progBindRecElimR -- ** Let Introduction , letIntroR - -- ** Let Floating + -- ** Let Floating Out , letFloatAppR , letFloatArgR , letFloatLetR @@ -22,11 +25,11 @@ , letFloatCastR , letFloatExprR , letFloatTopR - -- ** Let Unfloating - , letUnfloatR - , letUnfloatAppR - , letUnfloatCaseR - , letUnfloatLamR + -- ** Let Floating In + , letFloatInR + , letFloatInAppR + , letFloatInCaseR + , letFloatInLamR -- ** Miscallaneous , reorderNonRecLetsR , letTupleR @@ -102,14 +105,14 @@ [ "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" ] - , external "let-unfloat" (promoteExprR letUnfloatR :: RewriteH Core) - [ "Unfloat a let if possible." ] .+ Commute .+ Shallow - , external "let-unfloat-app" ((promoteExprR letUnfloatAppR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core) + , external "let-float-in" (promoteExprR letFloatInR :: RewriteH Core) + [ "Float-in a let if possible." ] .+ Commute .+ Shallow + , external "let-float-in-app" ((promoteExprR letFloatInAppR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core) [ "let v = ev in f a ==> (let v = ev in f) (let v = ev in a)" ] .+ Commute .+ Shallow - , external "let-unfloat-case" ((promoteExprR letUnfloatCaseR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core) + , external "let-float-in-case" ((promoteExprR letFloatInCaseR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core) [ "let v = ev in case s of p -> e ==> case (let v = ev in s) of p -> let v = ev in e" , "if v does not shadow a pattern binder in p" ] .+ Commute .+ Shallow - , external "let-unfloat-lam" ((promoteExprR letUnfloatLamR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core) + , external "let-float-in-lam" ((promoteExprR letFloatInLamR >+> anybuR (promoteExprR letElimR)) :: RewriteH Core) [ "let v = ev in \\ x -> e ==> \\ x -> let v = ev in e" , "if v does not shadow x" ] .+ Commute .+ Shallow , external "reorder-lets" (promoteExprR . reorderNonRecLetsR :: [TH.Name] -> RewriteH Core) @@ -118,16 +121,26 @@ , external "let-tuple" (promoteExprR . letTupleR . show :: TH.Name -> RewriteH Core) [ "Combine nested non-recursive lets into case of a tuple." , "E.g. let {v1 = e1 ; v2 = e2 ; v3 = e3} in body ==> case (e1,e2,e3) of {(v1,v2,v3) -> body}" ] .+ Commute + , external "prog-bind-elim" (promoteProgR progBindElimR :: RewriteH Core) + [ "Remove unused top-level binding(s)." + , "prog-bind-nonrec-elim <+ prog-bind-rec-elim" ] .+ Eval .+ Shallow + , external "prog-bind-nonrec-elim" (promoteProgR progBindNonRecElimR :: RewriteH Core) + [ "Remove unused top-level binding(s)." + , "v = e : prog ==> prog, if v is not free in prog and not exported." ] .+ Eval .+ Shallow + , external "prog-bind-rec-elim" (promoteProgR progBindRecElimR :: RewriteH Core) + [ "Remove unused top-level binding(s)." + , "v+ = e+ : prog ==> v* = e* : prog, where v* is a subset of v+ consisting" + , "of vs that are free in prog or e+, or exported." ] .+ Eval .+ Shallow ] ------------------------------------------------------------------------------------------- -- | (let x = e1 in e2) ==> (e2[e1/x]), (x must not be free in e1) -letSubstR :: (AddBindings c, ExtendPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr +letSubstR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, MonadCatch m) => Rewrite c m CoreExpr letSubstR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstR -- | As 'letNonRecSubstSafeR', but attempting to convert a singleton recursive binding to a non-recursive binding first. -letSubstSafeR :: (AddBindings c, ExtendPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr +letSubstSafeR :: (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr letSubstSafeR = letAllR (tryR recToNonrecR) idR >>> letNonRecSubstSafeR -- | @Let (NonRec v e) body@ ==> @body[e/v]@ @@ -135,11 +148,11 @@ letNonRecSubstR = prefixFailMsg "Let substitution failed: " $ withPatFailMsg (wrongExprForm "Let (NonRec v rhs) body") $ do Let (NonRec v rhs) body <- idR - return body >>> substExprR v rhs + return (substCoreExpr v rhs body) -- | Currently we always substitute types and coercions, and use a heuristic to decide whether to substitute expressions. -- This may need revisiting. -letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr +letNonRecSubstSafeR :: forall c m. (AddBindings c, ExtendPath c Crumb, ReadPath c Crumb, ReadBindings c, MonadCatch m) => Rewrite c m CoreExpr letNonRecSubstSafeR = do Let (NonRec v _) _ <- idR when (isId v) $ guardMsgM (safeSubstT v) "safety criteria not met." @@ -225,16 +238,41 @@ else if bs `subVarSet` liveBinders then fail "no dead binders to eliminate." else return $ Let (Rec $ filter ((`elemVarSet` liveBinders) . fst) bnds) body - where - chaseDependencies :: VarSet -> [(Var,VarSet)] -> VarSet - chaseDependencies usedIds bsAndFrees = case partition ((`elemVarSet` usedIds) . fst) bsAndFrees of - ([],_) -> usedIds - (used,unused) -> chaseDependencies (unionVarSets (usedIds : map snd used)) unused +progBindElimR :: MonadCatch m => Rewrite c m CoreProg +progBindElimR = progBindNonRecElimR <+ progBindRecElimR + +progBindNonRecElimR :: MonadCatch m => Rewrite c m CoreProg +progBindNonRecElimR = withPatFailMsg (wrongExprForm "ProgCons (NonRec v e1) e2") $ do + ProgCons (NonRec v _) p <- idR + guardMsg (v `notElemVarSet` freeVarsProg p) "variable appears in program body." + guardMsg (not (isExportedId v)) "variable is exported." + return p + +-- | Remove all unused bindings at the top level. +progBindRecElimR :: MonadCatch m => Rewrite c m CoreProg +progBindRecElimR = withPatFailMsg (wrongExprForm "ProgCons (Rec v e1) e2") $ + do ProgCons (Rec bnds) p <- idR + let pFrees = freeVarsProg p + bsAndFrees = map (second freeIdsExpr) bnds + usedIds = chaseDependencies pFrees bsAndFrees + bs = mkVarSet (map fst bsAndFrees) + liveBinders = (bs `intersectVarSet` usedIds) `unionVarSet` (filterVarSet isExportedId bs) + if isEmptyVarSet liveBinders + then return p + else if bs `subVarSet` liveBinders + then fail "no dead binders to eliminate." + else return $ ProgCons (Rec $ filter ((`elemVarSet` liveBinders) . fst) bnds) p + +chaseDependencies :: VarSet -> [(Var,VarSet)] -> VarSet +chaseDependencies usedIds bsAndFrees = case partition ((`elemVarSet` usedIds) . fst) bsAndFrees of + ([],_) -> usedIds + (used,unused) -> chaseDependencies (unionVarSets (usedIds : map snd used)) unused + ------------------------------------------------------------------------------------------- -- | @let v = ev in e@ ==> @case ev of v -> e@ -letToCaseR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +letToCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr letToCaseR = prefixFailMsg "Converting Let to Case failed: " $ withPatFailMsg (wrongExprForm "Let (NonRec v e1) e2") $ do Let (NonRec v ev) _ <- idR @@ -246,7 +284,7 @@ ------------------------------------------------------------------------------------------- -- | @(let v = ev in e) x@ ==> @let v = ev in e x@ -letFloatAppR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatAppR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatAppR = prefixFailMsg "Let floating from App function failed: " $ withPatFailMsg (wrongExprForm "App (Let bnds body) e") $ do App (Let bnds body) e <- idR @@ -256,7 +294,7 @@ else appAllR (alphaLetVarsR $ varSetElems vs) idR >>> letFloatAppR -- | @f (let v = ev in e)@ ==> @let v = ev in f e@ -letFloatArgR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatArgR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatArgR = prefixFailMsg "Let floating from App argument failed: " $ withPatFailMsg (wrongExprForm "App f (Let bnds body)") $ do App f (Let bnds body) <- idR @@ -266,7 +304,7 @@ else appAllR idR (alphaLetVarsR $ varSetElems vs) >>> letFloatArgR -- | @let v = (let bds in e1) in e2@ ==> @let bds in let v = e1 in e2@ -letFloatLetR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatLetR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatLetR = prefixFailMsg "Let floating from Let failed: " $ withPatFailMsg (wrongExprForm "Let (NonRec v (Let bds e1)) e2") $ do Let (NonRec v (Let bds e1)) e2 <- idR @@ -278,7 +316,7 @@ -- | @(\ v -> let binds in e2)@ ==> @let binds in (\ v1 -> e2)@ -- Fails if @v@ occurs in the RHS of @binds@. -- If @v@ is shadowed in binds, then @v@ will be alpha-renamed. -letFloatLamR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatLamR = prefixFailMsg "Let floating from Lam failed: " $ withPatFailMsg (wrongExprForm "Lam v1 (Let bds body)") $ do Lam v (Let binds body) <- idR @@ -291,7 +329,7 @@ -- | @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@. -letFloatCaseR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatCaseR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatCaseR = prefixFailMsg "Let floating from Case failed: " $ withPatFailMsg (wrongExprForm "Case (Let bnds e) w ty alts") $ do Case (Let bnds e) w ty alts <- idR @@ -308,12 +346,12 @@ return $ Let bnds (Cast e co) -- | Float a 'Let' through an expression, whatever the context. -letFloatExprR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr +letFloatExprR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreExpr letFloatExprR = setFailMsg "Unsuitable expression for Let floating." $ letFloatArgR <+ letFloatAppR <+ letFloatLetR <+ letFloatLamR <+ letFloatCaseR <+ letFloatCastR -- | @'ProgCons' ('NonRec' v ('Let' bds e)) p@ ==> @'ProgCons' bds ('ProgCons' ('NonRec' v e) p)@ -letFloatTopR :: (ExtendPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg +letFloatTopR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, BoundVars c) => Rewrite c HermitM CoreProg letFloatTopR = prefixFailMsg "Let floating to top level failed: " $ withPatFailMsg (wrongExprForm "NonRec v (Let bds e) `ProgCons` p") $ do ProgCons (NonRec v (Let bds e)) p <- idR @@ -326,34 +364,35 @@ ------------------------------------------------------------------------------------------- --- | Unfloat a 'Let' if possible. -letUnfloatR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -letUnfloatR = letUnfloatCaseR <+ letUnfloatAppR <+ letUnfloatLamR +-- | Float in a 'Let' if possible. +letFloatInR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr +letFloatInR = letFloatInCaseR <+ letFloatInAppR <+ letFloatInLamR -- | @let v = ev in case s of p -> e@ ==> @case (let v = ev in s) of p -> let v = ev in e@, -- if @v@ does not shadow a pattern binder in @p@ -letUnfloatCaseR :: MonadCatch m => Rewrite c m CoreExpr -letUnfloatCaseR = prefixFailMsg "Let unfloating from case failed: " $ +letFloatInCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr +letFloatInCaseR = prefixFailMsg "Let floating in to case failed: " $ withPatFailMsg (wrongExprForm "Let bnds (Case s w ty alts)") $ do Let bnds (Case s w ty alts) <- idR let bs = bindVars bnds captured = bs `intersect` (w : concatMap altVars alts) guardMsg (null captured) "let bindings would capture case pattern bindings." - let unbound = mkVarSet bs `intersectVarSet` tyVarsOfType ty + let unbound = mkVarSet bs `intersectVarSet` (tyVarsOfType ty `unionVarSet` freeVarsVar w) guardMsg (isEmptyVarSet unbound) "type variables in case signature would become unbound." - return $ Case (Let bnds s) w ty $ mapAlts (Let bnds) alts + return (Case (Let bnds s) w ty alts) >>> caseAllR idR idR idR (\_ -> altAllR idR (\_ -> idR) (arr (Let bnds) >>> alphaLetR)) -- | @let v = ev in f a@ ==> @(let v = ev in f) (let v = ev in a)@ -letUnfloatAppR :: MonadCatch m => Rewrite c m CoreExpr -letUnfloatAppR = prefixFailMsg "Let unfloating from app failed: " $ +letFloatInAppR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb) => Rewrite c HermitM CoreExpr +letFloatInAppR = prefixFailMsg "Let floating in to app failed: " $ withPatFailMsg (wrongExprForm "Let bnds (App e1 e2)") $ do Let bnds (App e1 e2) <- idR - return $ App (Let bnds e1) (Let bnds e2) + lhs <- return (Let bnds e1) >>> alphaLetR + return $ App lhs (Let bnds e2) -- | @let v = ev in \ x -> e@ ==> @\x -> let v = ev in e@ -- if @v@ does not shadow @x@ -letUnfloatLamR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -letUnfloatLamR = prefixFailMsg "Let unfloating from lambda failed: " $ +letFloatInLamR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr +letFloatInLamR = prefixFailMsg "Let floating in to lambda failed: " $ withPatFailMsg (wrongExprForm "Let bnds (Lam v e)") $ do Let bnds (Lam v e) <- idR safe <- letT (arr bindVars) lamVarT $ flip notElem diff --git a/src/HERMIT/Dictionary/Navigation.hs b/src/HERMIT/Dictionary/Navigation.hs --- a/src/HERMIT/Dictionary/Navigation.hs +++ b/src/HERMIT/Dictionary/Navigation.hs @@ -167,19 +167,19 @@ ----------------------------------------------------------------------- -- | Find all possible targets of 'occurrenceOfT'. -occurrenceOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet +occurrenceOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet occurrenceOfTargetsT = allT $ crushbuT (arr varOccurrence >>> projectT >>^ unitVarSet) -- | Find all possible targets of 'bindingOfT'. -bindingOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet +bindingOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet bindingOfTargetsT = allT $ crushbuT (arr binders) -- | Find all possible targets of 'bindingGroupOfT'. -bindingGroupOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet +bindingGroupOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet bindingGroupOfTargetsT = allT $ crushbuT (promoteBindT $ arr (mkVarSet . bindVars)) -- | Find all possible targets of 'rhsOfT'. -rhsOfTargetsT :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet +rhsOfTargetsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m CoreTC VarSet rhsOfTargetsT = crushbuT (promoteBindT (arr binderBind) <+ promoteDefT (arr binderDef)) ----------------------------------------------------------------------- diff --git a/src/HERMIT/Dictionary/Query.hs b/src/HERMIT/Dictionary/Query.hs --- a/src/HERMIT/Dictionary/Query.hs +++ b/src/HERMIT/Dictionary/Query.hs @@ -12,6 +12,7 @@ import Control.Arrow import Data.List (intercalate) +import qualified Data.Map as Map import HERMIT.Context import HERMIT.Core @@ -52,7 +53,11 @@ con = "Constructor: " ++ coreTCConstructor coreTC pa = "Path: " ++ showCrumbs (snocPathToPath $ absPath c) children = "Children: " ++ showCrumbs crumbs - bds = "Local bindings in scope: " ++ showVarSet (boundVars c) + bds = "Local bindings in scope: " ++ concat + [ "\n " ++ var2String k ++ " : " ++ hermitBindingSummary hbs + | (k,hbs) <- Map.toList (hermitBindings c) + ] +-- showVarSet (boundVars c) freevars = [ "Free local identifiers: " ++ showVarSet (filterVarSet isLocalId fvs) , "Free global identifiers: " ++ showVarSet (filterVarSet isGlobalId fvs) , "Free type variables: " ++ showVarSet (filterVarSet isTyVar fvs) @@ -63,6 +68,8 @@ in [(if isKind tyK then "Kind: " else "Type: ") ++ showPpr dynFlags tyK] ++ case e of Var i -> [ "" + , "OccName: " ++ getOccString i + , "Unique: " ++ show (getUnique i) , "Identifier arity: " ++ show (arityOf c i) , "Identifier binding depth: " ++ runKureM show id (lookupHermitBindingDepth i c) ] _ -> [] @@ -159,7 +166,7 @@ guardMsg (core1 `coreAlphaEq` core2) "core fragments are not alpha-equivalent." -- | Compare the definitions of two identifiers for alpha-equality. -compareBoundIdsT :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Id -> Id -> Translate c HermitM x () +compareBoundIdsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Id -> Id -> Translate c HermitM x () compareBoundIdsT i1 i2 = do e1 <- fst ^<< getUnfoldingT AllBinders <<< return i1 e2 <- replaceVarR i2 i1 <<< fst ^<< getUnfoldingT AllBinders <<< return i2 @@ -167,7 +174,7 @@ guardMsg (e1 `exprAlphaEq` e2) "bindings are not alpha-equivalent." -- | Compare the definitions of the two named identifiers for alpha-equality. -compareBoundIds :: (ExtendPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) => TH.Name -> TH.Name -> Translate c HermitM x () +compareBoundIds :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c, HasGlobalRdrEnv c) => TH.Name -> TH.Name -> Translate c HermitM x () compareBoundIds nm1 nm2 = do i1 <- findIdT nm1 i2 <- findIdT nm2 compareBoundIdsT i1 i2 diff --git a/src/HERMIT/Dictionary/Undefined.hs b/src/HERMIT/Dictionary/Undefined.hs --- a/src/HERMIT/Dictionary/Undefined.hs +++ b/src/HERMIT/Dictionary/Undefined.hs @@ -128,7 +128,7 @@ ------------------------------------------------------------------------------------------------------ -- | undefinedExprR = undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR -undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr +undefinedExprR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedExprR = setFailMsg "undefined-expr failed." (undefinedAppR <+ undefinedLamR <+ undefinedLetR <+ undefinedCastR <+ undefinedTickR <+ undefinedCaseR) @@ -141,13 +141,13 @@ replaceWithUndefinedR -- | @(\ v -> undefined ty1)@ ==> @undefined ty2@ (where v is not a 'TyVar') -undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr +undefinedLamR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedLamR = prefixFailMsg "undefined-lam failed: " $ do lamT successT isUndefinedValT (<>) replaceWithUndefinedR -- | let bds in (undefined ty) ==> undefined ty -undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr +undefinedLetR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedLetR = prefixFailMsg "undefined-let failed: " $ do letT successT isUndefinedValT (<>) replaceWithUndefinedR @@ -165,17 +165,17 @@ replaceWithUndefinedR -- | undefinedCaseR = undefinedCaseScrutineeR <+ undefinedCaseAltsR -undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr +undefinedCaseR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseR = setFailMsg "undefined-case failed" (undefinedCaseScrutineeR <+ undefinedCaseAltsR) -- | case (undefined ty) of alts ==> undefined ty -undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr +undefinedCaseScrutineeR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseScrutineeR = prefixFailMsg "undefined-case failed: " $ do caseT isUndefinedValT successT successT (const successT) (\ _ _ _ _ -> ()) replaceWithUndefinedR -- | case e of {pat_1 -> undefined ty ; pat_2 -> undefined ty ; ... ; pat_n -> undefined ty} ==> undefined ty -undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr +undefinedCaseAltsR :: (AddBindings c, BoundVars c, ExtendPath c Crumb, ReadPath c Crumb, HasGlobalRdrEnv c, MonadCatch m, HasDynFlags m, MonadThings m) => Rewrite c m CoreExpr undefinedCaseAltsR = prefixFailMsg "undefined-case-alts failed: " $ do caseAltT successT successT successT (const (successT,const successT,isUndefinedValT)) (\ _ _ _ _ -> ()) replaceWithUndefinedR diff --git a/src/HERMIT/Dictionary/Unfold.hs b/src/HERMIT/Dictionary/Unfold.hs --- a/src/HERMIT/Dictionary/Unfold.hs +++ b/src/HERMIT/Dictionary/Unfold.hs @@ -16,6 +16,7 @@ import Control.Arrow import Control.Monad +import Data.List (intercalate) import qualified Data.Map as Map import qualified Language.Haskell.TH as TH @@ -89,26 +90,26 @@ -- | A more powerful 'inline'. Matches two cases: -- Var ==> inlines -- App ==> inlines the head of the function call for the app tree -unfoldR :: forall c. (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +unfoldR :: forall c. (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr unfoldR = prefixFailMsg "unfold failed: " (go >>> cleanupUnfoldR) where go :: Rewrite c HermitM CoreExpr go = inlineR <+ appAllR go idR -unfoldPredR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr +unfoldPredR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => (Id -> [CoreExpr] -> Bool) -> Rewrite c HermitM CoreExpr unfoldPredR p = callPredT p >> unfoldR -unfoldNameR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr +unfoldNameR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => TH.Name -> Rewrite c HermitM CoreExpr unfoldNameR nm = prefixFailMsg ("unfold '" ++ show nm ++ " failed: ") (callNameT nm >> unfoldR) -unfoldNamesR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr +unfoldNamesR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => [TH.Name] -> Rewrite c HermitM CoreExpr unfoldNamesR [] = fail "unfold-names failed: no names given." unfoldNamesR nms = setFailMsg "unfold-names failed." $ orR (map unfoldNameR nms) -unfoldSaturatedR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +unfoldSaturatedR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr unfoldSaturatedR = callSaturatedT >> unfoldR -specializeR :: (ExtendPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr +specializeR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, ReadBindings c) => Rewrite c HermitM CoreExpr specializeR = unfoldPredR (const $ all isTyCoArg) -- NOTE: Using a Rewrite because of the way the Kernel is set up. @@ -133,14 +134,16 @@ -- | Apply a stashed definition (like inline, but looks in stash instead of context). unfoldStashR :: ReadBindings c => String -> Rewrite c HermitM CoreExpr -unfoldStashR label = setFailMsg "Inlining stashed definition failed: " $ +unfoldStashR label = prefixFailMsg "Inlining stashed definition failed: " $ withPatFailMsg (wrongExprForm "Var v") $ do (c, Var v) <- exposeT constT $ do Def i rhs <- lookupDef label + dflags <- getDynFlags if idName i == idName v -- TODO: Is there a reason we're not just using equality on Id? - then if all (inScope c) $ varSetElems $ freeVarsExpr rhs - then return rhs - else fail "some free variables in stashed definition are no longer in scope." + then let fvars = varSetElems $ localFreeVarsExpr rhs + in if all (inScope c) fvars + then return rhs + else fail $ "free variables " ++ intercalate "," (map (showPpr dflags) (filter (not . inScope c) fvars)) ++ " in stashed definition are no longer in scope." else fail $ "stashed definition applies to " ++ var2String i ++ " not " ++ var2String v showStashT :: Injection CoreDef a => PrettyC -> PrettyH a -> Translate c HermitM a DocH diff --git a/src/HERMIT/External.hs b/src/HERMIT/External.hs --- a/src/HERMIT/External.hs +++ b/src/HERMIT/External.hs @@ -9,6 +9,8 @@ , externName , externDyn , externHelp + , externTypeString + , externTypeArgResString , Dictionary , toDictionary , toHelp @@ -52,6 +54,7 @@ import Data.Map hiding (map) import Data.Dynamic import Data.List +import Data.Typeable.Internal (TypeRep(..), funTc) import qualified Language.Haskell.TH as TH @@ -250,18 +253,39 @@ toHelp = fromListWith (++) . map toH where toH :: External -> (ExternalName,ExternalHelp) - toH e = (externName e, spaceout (externName e ++ " :: " ++ fixup (show (dynTypeRep (externDyn e)))) + toH e = (externName e, spaceout (externName e ++ " :: " ++ externTypeString e) (show (externTags e)) : externHelp e) spaceout xs ys = xs ++ replicate (width - (length xs + length ys)) ' ' ++ ys width = 78 - fixup :: String -> String - fixup xs | "Box" `isPrefixOf` xs = fixup (drop 3 xs) - fixup (x:xs) = x : fixup xs - fixup [] = [] +-- | Get a string representation of the (monomorphic) type of an 'External' +externTypeString :: External -> String +externTypeString = deBoxify . show . dynTypeRep . externDyn +-- | Remove the word 'Box' from a string. +deBoxify :: String -> String +deBoxify xs | "Box" `isPrefixOf` xs = deBoxify (drop 3 xs) +deBoxify (x:xs) = x : deBoxify xs +deBoxify [] = [] + +externTypeArgResString :: External -> ([String], String) +externTypeArgResString e = (map (deBoxify . show) aTys, deBoxify (show rTy)) + where (aTys, rTy) = splitExternFunType e + +splitExternFunType :: External -> ([TypeRep], TypeRep) +splitExternFunType = splitFunTyArgs . dynTypeRep . externDyn + +splitFunTyArgs :: TypeRep -> ([TypeRep], TypeRep) +splitFunTyArgs tr = case splitFunTyMaybe tr of + Nothing -> ([], tr) + Just (a, r) -> let (as, r') = splitFunTyArgs r + in (a:as, r') + +splitFunTyMaybe :: TypeRep -> Maybe (TypeRep, TypeRep) +splitFunTyMaybe (TypeRep _ tc [a,r]) | tc == funTc = Just (a,r) +splitFunTyMaybe _ = Nothing ----------------------------------------------------------------- diff --git a/src/HERMIT/GHC.hs b/src/HERMIT/GHC.hs --- a/src/HERMIT/GHC.hs +++ b/src/HERMIT/GHC.hs @@ -26,6 +26,7 @@ , occurAnalyseExpr , isKind , isLiftedTypeKindCon + , exprType -- TODO: remove once we can use GHC's exprType again #if __GLASGOW_HASKELL__ > 706 , coAxiomName , CoAxiom.BranchIndex @@ -36,28 +37,40 @@ , varSetToStrings , showVarSet , Pair(..) + , bndrRuleAndUnfoldingVars #if __GLASGOW_HASKELL__ <= 706 , Control.Monad.IO.Class.liftIO #endif ) where #if __GLASGOW_HASKELL__ <= 706 +-- GHC 7.6 import qualified Control.Monad.IO.Class import qualified MonadUtils (MonadIO,liftIO) -import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, liftIO) +import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, exprType, liftIO) #else +#if __GLASGOW_HASKELL__ < 708 +-- TODO: remove this case once 7.8 comes out, only here because +-- my HEAD installs are pre-8522 patch, and I don't want to rebuild +-- on four different machines just yet. +-- GHC 7.7.XXX +import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars, exprType) -- we hide these so that they don't get inadvertently used. See Core.hs +#else +-- GHC 7.8 import GhcPlugins hiding (exprFreeVars, exprFreeIds, bindFreeVars) -- we hide these so that they don't get inadvertently used. See Core.hs #endif +#endif -- hacky direct GHC imports import Convert (thRdrNameGuesses) -import TysPrim (alphaTyVars) -import TypeRep (Type(..),TyLit(..)) -import Panic (GhcException(ProgramError), throwGhcException) import CoreArity import Kind (isKind,isLiftedTypeKindCon) import OccurAnal (occurAnalyseExpr) import Pair (Pair(..)) +import Panic (GhcException(ProgramError), throwGhcException) +import PprCore (pprCoreExpr) +import TypeRep (Type(..),TyLit(..)) +import TysPrim (alphaTy, alphaTyVars) #if __GLASGOW_HASKELL__ <= 706 import Data.Maybe (isJust) @@ -70,6 +83,32 @@ -------------------------------------------------------------------------- +#if __GLASGOW_HASKELL < 708 +-- Note: once 7.8 comes out, change condition above to "<= 706" +exprType :: CoreExpr -> Type +-- ^ Recover the type of a well-typed Core expression. Fails when +-- applied to the actual 'CoreSyn.Type' expression as it cannot +-- really be said to have a type +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let bind body) + | NonRec tv rhs <- bind + , Type ty <- rhs = substTyWith [tv] [ty] (exprType body) + | otherwise = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkPiType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs e (exprType fun) args + +exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy +#endif + +-------------------------------------------------------------------------- + -- | Convert a 'VarSet' to a list of user-readable strings. varSetToStrings :: VarSet -> [String] varSetToStrings = map var2String . varSetElems @@ -225,3 +264,10 @@ #endif -------------------------------------------------------------------------- + +-- This function is copied from GHC, which defines but doesn't expose it. +-- A 'let' can bind a type variable, and idRuleVars assumes +-- it's seeing an Id. This function tests first. +bndrRuleAndUnfoldingVars :: Var -> VarSet +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet + | otherwise = idRuleAndUnfoldingVars v diff --git a/src/HERMIT/Kure.hs b/src/HERMIT/Kure.hs --- a/src/HERMIT/Kure.hs +++ b/src/HERMIT/Kure.hs @@ -110,6 +110,7 @@ type PathH = Path Crumb -- I find it annoying that Applicative is not a superclass of Monad. +-- This causes a warning now, and will need to be CPP'd for 7.10 (<$>) :: Monad m => (a -> b) -> m a -> m b (<$>) = liftM {-# INLINE (<$>) #-} @@ -121,7 +122,7 @@ --------------------------------------------------------------------- -- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives. -instance (ExtendPath c Crumb, AddBindings c) => Walker c Core where +instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c Core where allR :: forall m. MonadCatch m => Rewrite c m Core -> Rewrite c m Core allR r = prefixFailMsg "allR failed: " $ @@ -174,7 +175,7 @@ --------------------------------------------------------------------- -- | Walking over types (only). -instance (ExtendPath c Crumb, AddBindings c) => Walker c Type where +instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c Type where allR :: MonadCatch m => Rewrite c m Type -> Rewrite c m Type allR r = prefixFailMsg "allR failed: " $ @@ -188,7 +189,7 @@ --------------------------------------------------------------------- -- | Walking over coercions (only). -instance (ExtendPath c Crumb, AddBindings c) => Walker c Coercion where +instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c Coercion where allR :: MonadCatch m => Rewrite c m Coercion -> Rewrite c m Coercion allR r = prefixFailMsg "allR failed: " $ @@ -211,7 +212,7 @@ --------------------------------------------------------------------- -- | Walking over types and coercions. -instance (ExtendPath c Crumb, AddBindings c) => Walker c TyCo where +instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c TyCo where allR :: forall m. MonadCatch m => Rewrite c m TyCo -> Rewrite c m TyCo allR r = prefixFailMsg "allR failed: " $ @@ -245,7 +246,7 @@ --------------------------------------------------------------------- -- | Walking over modules, programs, binding groups, definitions, expressions and case alternatives. -instance (ExtendPath c Crumb, AddBindings c) => Walker c CoreTC where +instance (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c) => Walker c CoreTC where allR :: forall m. MonadCatch m => Rewrite c m CoreTC -> Rewrite c m CoreTC allR r = prefixFailMsg "allR failed: " $ @@ -318,24 +319,24 @@ {-# INLINE progNilT #-} -- | Translate a program of the form: ('CoreBind' @:@ 'CoreProg') -progConsT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreProg a2 -> (a1 -> a2 -> b) -> Translate c m CoreProg b +progConsT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreProg a2 -> (a1 -> a2 -> b) -> Translate c m CoreProg b progConsT t1 t2 f = translate $ \ c -> \case ProgCons bd p -> f <$> apply t1 (c @@ ProgCons_Head) bd <*> apply t2 (addBindingGroup bd c @@ ProgCons_Tail) p _ -> fail "not a non-empty program." {-# INLINE progConsT #-} -- | Rewrite all children of a program of the form: ('CoreBind' @:@ 'CoreProg') -progConsAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg +progConsAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg progConsAllR r1 r2 = progConsT r1 r2 ProgCons {-# INLINE progConsAllR #-} -- | Rewrite any children of a program of the form: ('CoreBind' @:@ 'CoreProg') -progConsAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg +progConsAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg progConsAnyR r1 r2 = unwrapAnyR $ progConsAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE progConsAnyR #-} -- | Rewrite one child of a program of the form: ('CoreBind' @:@ 'CoreProg') -progConsOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg +progConsOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreProg -> Rewrite c m CoreProg progConsOneR r1 r2 = unwrapOneR $ progConsAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE progConsOneR #-} @@ -365,7 +366,7 @@ -- | Translate a binding group of the form: @Rec@ ['CoreDef'] -recT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a) -> ([a] -> b) -> Translate c m CoreBind b +recT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a) -> ([a] -> b) -> Translate c m CoreBind b recT t f = translate $ \ c -> \case Rec bds -> -- The group is recursive, so we add all other bindings in the group to the context (excluding the one under consideration). f <$> sequence [ apply (t n) (addDefBindingsExcept n bds c @@ Rec_Def n) (Def i e) -- here we convert from (Id,CoreExpr) to CoreDef @@ -375,63 +376,63 @@ {-# INLINE recT #-} -- | Rewrite all children of a binding group of the form: @Rec@ ['CoreDef'] -recAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind +recAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind recAllR rs = recT rs defsToRecBind {-# INLINE recAllR #-} -- | Rewrite any children of a binding group of the form: @Rec@ ['CoreDef'] -recAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind +recAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind recAnyR rs = unwrapAnyR $ recAllR (wrapAnyR . rs) {-# INLINE recAnyR #-} -- | Rewrite one child of a binding group of the form: @Rec@ ['CoreDef'] -recOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind +recOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreBind recOneR rs = unwrapOneR $ recAllR (wrapOneR . rs) {-# INLINE recOneR #-} --------------------------------------------------------------------- -- | Translate a recursive definition of the form: @Def@ 'Id' 'CoreExpr' -defT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Id a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreDef b +defT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Id a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreDef b defT t1 t2 f = translate $ \ c (Def i e) -> f <$> apply t1 (c @@ Def_Id) i <*> apply t2 (addDefBinding i c @@ Def_RHS) e {-# INLINE defT #-} -- | Rewrite all children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr' -defAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef +defAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef defAllR r1 r2 = defT r1 r2 Def {-# INLINE defAllR #-} -- | Rewrite any children of a recursive definition of the form: @Def@ 'Id' 'CoreExpr' -defAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef +defAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef defAnyR r1 r2 = unwrapAnyR (defAllR (wrapAnyR r1) (wrapAnyR r2)) {-# INLINE defAnyR #-} -- | Rewrite one child of a recursive definition of the form: @Def@ 'Id' 'CoreExpr' -defOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef +defOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Id -> Rewrite c m CoreExpr -> Rewrite c m CoreDef defOneR r1 r2 = unwrapOneR (defAllR (wrapOneR r1) (wrapOneR r2)) {-# INLINE defOneR #-} --------------------------------------------------------------------- -- | Translate a case alternative of the form: ('AltCon', ['Var'], 'CoreExpr') -altT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m AltCon a1 -> (Int -> Translate c m Var a2) -> Translate c m CoreExpr a3 -> (a1 -> [a2] -> a3 -> b) -> Translate c m CoreAlt b +altT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m AltCon a1 -> (Int -> Translate c m Var a2) -> Translate c m CoreExpr a3 -> (a1 -> [a2] -> a3 -> b) -> Translate c m CoreAlt b altT t1 ts t2 f = translate $ \ c (con,vs,e) -> f <$> apply t1 (c @@ Alt_Con) con <*> sequence [ apply (ts n) (c @@ Alt_Var n) v | (v,n) <- zip vs [1..] ] <*> apply t2 (addAltBindings vs c @@ Alt_RHS) e {-# INLINE altT #-} -- | Rewrite all children of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr') -altAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt +altAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt altAllR r1 rs r2 = altT r1 rs r2 (,,) {-# INLINE altAllR #-} -- | Rewrite any children of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr') -altAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt +altAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt altAnyR r1 rs r2 = unwrapAnyR (altAllR (wrapAnyR r1) (wrapAnyR . rs) (wrapAnyR r2)) {-# INLINE altAnyR #-} -- | Rewrite one child of a case alternative of the form: ('AltCon', 'Id', 'CoreExpr') -altOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt +altOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m AltCon -> (Int -> Rewrite c m Var) -> Rewrite c m CoreExpr -> Rewrite c m CoreAlt altOneR r1 rs r2 = unwrapOneR (altAllR (wrapOneR r1) (wrapOneR . rs) (wrapOneR r2)) {-# INLINE altOneR #-} @@ -487,30 +488,30 @@ -- | Translate an expression of the form: @Lam@ 'Var' 'CoreExpr' -lamT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b +lamT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b lamT t1 t2 f = translate $ \ c -> \case Lam v e -> f <$> apply t1 (c @@ Lam_Var) v <*> apply t2 (addLambdaBinding v c @@ Lam_Body) e _ -> fail "not a lambda." {-# INLINE lamT #-} -- | Rewrite all children of an expression of the form: @Lam@ 'Var' 'CoreExpr' -lamAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +lamAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr lamAllR r1 r2 = lamT r1 r2 Lam {-# INLINE lamAllR #-} -- | Rewrite any children of an expression of the form: @Lam@ 'Var' 'CoreExpr' -lamAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +lamAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr lamAnyR r1 r2 = unwrapAnyR $ lamAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE lamAnyR #-} -- | Rewrite one child of an expression of the form: @Lam@ 'Var' 'CoreExpr' -lamOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +lamOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr lamOneR r1 r2 = unwrapOneR $ lamAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE lamOneR #-} -- | Translate an expression of the form: @Let@ 'CoreBind' 'CoreExpr' -letT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b +letT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreBind a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m CoreExpr b letT t1 t2 f = translate $ \ c -> \case Let bds e -> -- Note we use the *original* context for the binding group. -- If the bindings are recursive, they will be added to the context by recT. @@ -519,23 +520,23 @@ {-# INLINE letT #-} -- | Rewrite all children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr' -letAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letAllR r1 r2 = letT r1 r2 Let {-# INLINE letAllR #-} -- | Rewrite any children of an expression of the form: @Let@ 'CoreBind' 'CoreExpr' -letAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letAnyR r1 r2 = unwrapAnyR $ letAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE letAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ 'CoreBind' 'CoreExpr' -letOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreBind -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letOneR r1 r2 = unwrapOneR $ letAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE letOneR #-} -- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] -caseT :: (ExtendPath c Crumb, AddBindings c, Monad m) +caseT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr e -> Translate c m Id w -> Translate c m Type ty @@ -553,7 +554,7 @@ {-# INLINE caseT #-} -- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] -caseAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) +caseAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreExpr -> Rewrite c m Id -> Rewrite c m Type @@ -563,7 +564,7 @@ {-# INLINE caseAllR #-} -- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] -caseAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) +caseAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m Id -> Rewrite c m Type @@ -573,7 +574,7 @@ {-# INLINE caseAnyR #-} -- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' ['CoreAlt'] -caseOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) +caseOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m Id -> Rewrite c m Type @@ -659,19 +660,19 @@ -- Some composite congruence combinators to export. -- | Translate a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@ -defOrNonRecT :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, AddBindings c, MonadCatch m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m g b +defOrNonRecT :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> (a1 -> a2 -> b) -> Translate c m g b defOrNonRecT t1 t2 f = promoteBindT (nonRecT t1 t2 f) <+ promoteDefT (defT t1 t2 f) {-# INLINE defOrNonRecT #-} -- | Rewrite all children of a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@ -defOrNonRecAllR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g +defOrNonRecAllR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g defOrNonRecAllR r1 r2 = promoteBindR (nonRecAllR r1 r2) <+ promoteDefR (defAllR r1 r2) {-# INLINE defOrNonRecAllR #-} -- | Rewrite any children of a definition of the form @NonRec 'Var' 'CoreExpr'@ or @Def 'Id' 'CoreExpr'@ -defOrNonRecAnyR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g +defOrNonRecAnyR :: (Injection CoreBind g, Injection CoreDef g, ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m g defOrNonRecAnyR r1 r2 = unwrapAnyR $ defOrNonRecAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE defOrNonRecAnyR #-} @@ -682,154 +683,154 @@ -- | Translate a binding group of the form: @Rec@ [('Id', 'CoreExpr')] -recDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> ([(a1,a2)] -> b) -> Translate c m CoreBind b +recDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> ([(a1,a2)] -> b) -> Translate c m CoreBind b recDefT ts = recT (\ n -> uncurry defT (ts n) (,)) {-# INLINE recDefT #-} -- | Rewrite all children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')] -recDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind +recDefAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind recDefAllR rs = recAllR (\ n -> uncurry defAllR (rs n)) {-# INLINE recDefAllR #-} -- | Rewrite any children of a binding group of the form: @Rec@ [('Id', 'CoreExpr')] -recDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind +recDefAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind recDefAnyR rs = recAnyR (\ n -> uncurry defAnyR (rs n)) {-# INLINE recDefAnyR #-} -- | Rewrite one child of a binding group of the form: @Rec@ [('Id', 'CoreExpr')] -recDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind +recDefOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreBind recDefOneR rs = recOneR (\ n -> uncurry defOneR (rs n)) {-# INLINE recDefOneR #-} -- | Translate a program of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' -consNonRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreProg a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreProg b +consNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreProg a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreProg b consNonRecT t1 t2 t3 f = progConsT (nonRecT t1 t2 (,)) t3 (uncurry f) {-# INLINE consNonRecT #-} -- | Rewrite all children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' -consNonRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consNonRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg consNonRecAllR r1 r2 r3 = progConsAllR (nonRecAllR r1 r2) r3 {-# INLINE consNonRecAllR #-} -- | Rewrite any children of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' -consNonRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consNonRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg consNonRecAnyR r1 r2 r3 = progConsAllR (nonRecAnyR r1 r2) r3 {-# INLINE consNonRecAnyR #-} -- | Rewrite one child of an expression of the form: (@NonRec@ 'Var' 'CoreExpr') @:@ 'CoreProg' -consNonRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consNonRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreProg -> Rewrite c m CoreProg consNonRecOneR r1 r2 r3 = progConsAllR (nonRecOneR r1 r2) r3 {-# INLINE consNonRecOneR #-} -- | Translate an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' -consRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate c m CoreProg b +consRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreProg a2 -> ([a1] -> a2 -> b) -> Translate c m CoreProg b consRecT ts t = progConsT (recT ts id) t {-# INLINE consRecT #-} -- | Rewrite all children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' -consRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecAllR rs r = progConsAllR (recAllR rs) r {-# INLINE consRecAllR #-} -- | Rewrite any children of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' -consRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecAnyR rs r = progConsAnyR (recAnyR rs) r {-# INLINE consRecAnyR #-} -- | Rewrite one child of an expression of the form: (@Rec@ ['CoreDef']) @:@ 'CoreProg' -consRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecOneR rs r = progConsOneR (recOneR rs) r {-# INLINE consRecOneR #-} -- | Translate an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' -consRecDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreProg a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreProg b +consRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreProg a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreProg b consRecDefT ts t = consRecT (\ n -> uncurry defT (ts n) (,)) t {-# INLINE consRecDefT #-} -- | Rewrite all children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' -consRecDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consRecDefAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecDefAllR rs r = consRecAllR (\ n -> uncurry defAllR (rs n)) r {-# INLINE consRecDefAllR #-} -- | Rewrite any children of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' -consRecDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consRecDefAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecDefAnyR rs r = consRecAnyR (\ n -> uncurry defAnyR (rs n)) r {-# INLINE consRecDefAnyR #-} -- | Rewrite one child of an expression of the form: (@Rec@ [('Id', 'CoreExpr')]) @:@ 'CoreProg' -consRecDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg +consRecDefOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreProg -> Rewrite c m CoreProg consRecDefOneR rs r = consRecOneR (\ n -> uncurry defOneR (rs n)) r {-# INLINE consRecDefOneR #-} -- | Translate an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' -letNonRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreExpr a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreExpr b +letNonRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m CoreExpr a2 -> Translate c m CoreExpr a3 -> (a1 -> a2 -> a3 -> b) -> Translate c m CoreExpr b letNonRecT t1 t2 t3 f = letT (nonRecT t1 t2 (,)) t3 (uncurry f) {-# INLINE letNonRecT #-} -- | Rewrite all children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' -letNonRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letNonRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letNonRecAllR r1 r2 r3 = letAllR (nonRecAllR r1 r2) r3 {-# INLINE letNonRecAllR #-} -- | Rewrite any children of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' -letNonRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letNonRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letNonRecAnyR r1 r2 r3 = letAnyR (nonRecAnyR r1 r2) r3 {-# INLINE letNonRecAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ (@NonRec@ 'Var' 'CoreExpr') 'CoreExpr' -letNonRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letNonRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letNonRecOneR r1 r2 r3 = letOneR (nonRecOneR r1 r2) r3 {-# INLINE letNonRecOneR #-} -- | Translate an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' -letRecT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate c m CoreExpr b +letRecT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Translate c m CoreDef a1) -> Translate c m CoreExpr a2 -> ([a1] -> a2 -> b) -> Translate c m CoreExpr b letRecT ts t = letT (recT ts id) t {-# INLINE letRecT #-} -- | Rewrite all children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' -letRecAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letRecAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecAllR rs r = letAllR (recAllR rs) r {-# INLINE letRecAllR #-} -- | Rewrite any children of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' -letRecAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letRecAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecAnyR rs r = letAnyR (recAnyR rs) r {-# INLINE letRecAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ (@Rec@ ['CoreDef']) 'CoreExpr' -letRecOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letRecOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> Rewrite c m CoreDef) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecOneR rs r = letOneR (recOneR rs) r {-# INLINE letRecOneR #-} -- | Translate an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' -letRecDefT :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreExpr a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreExpr b +letRecDefT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Translate c m Id a1, Translate c m CoreExpr a2)) -> Translate c m CoreExpr a3 -> ([(a1,a2)] -> a3 -> b) -> Translate c m CoreExpr b letRecDefT ts t = letRecT (\ n -> uncurry defT (ts n) (,)) t {-# INLINE letRecDefT #-} -- | Rewrite all children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' -letRecDefAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letRecDefAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecDefAllR rs r = letRecAllR (\ n -> uncurry defAllR (rs n)) r {-# INLINE letRecDefAllR #-} -- | Rewrite any children of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' -letRecDefAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letRecDefAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecDefAnyR rs r = letRecAnyR (\ n -> uncurry defAnyR (rs n)) r {-# INLINE letRecDefAnyR #-} -- | Rewrite one child of an expression of the form: @Let@ (@Rec@ [('Id', 'CoreExpr')]) 'CoreExpr' -letRecDefOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr +letRecDefOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => (Int -> (Rewrite c m Id, Rewrite c m CoreExpr)) -> Rewrite c m CoreExpr -> Rewrite c m CoreExpr letRecDefOneR rs r = letRecOneR (\ n -> uncurry defOneR (rs n)) r {-# INLINE letRecDefOneR #-} -- | Translate an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] -caseAltT :: (ExtendPath c Crumb, AddBindings c, Monad m) +caseAltT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m CoreExpr sc -> Translate c m Id w -> Translate c m Type ty @@ -839,7 +840,7 @@ {-# INLINE caseAltT #-} -- | Rewrite all children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] -caseAltAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) +caseAltAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m CoreExpr -> Rewrite c m Id -> Rewrite c m Type @@ -849,7 +850,7 @@ {-# INLINE caseAltAllR #-} -- | Rewrite any children of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] -caseAltAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) +caseAltAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m Id -> Rewrite c m Type @@ -859,7 +860,7 @@ {-# INLINE caseAltAnyR #-} -- | Rewrite one child of an expression of the form: @Case@ 'CoreExpr' 'Id' 'Type' [('AltCon', ['Var'], 'CoreExpr')] -caseAltOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) +caseAltOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m CoreExpr -> Rewrite c m Id -> Rewrite c m Type @@ -946,24 +947,24 @@ -- | Translate a type of the form: @ForAllTy@ 'Var' 'Type' -forAllTyT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b +forAllTyT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m Var a1 -> Translate c m Type a2 -> (a1 -> a2 -> b) -> Translate c m Type b forAllTyT t1 t2 f = translate $ \ c -> \case ForAllTy v ty -> f <$> apply t1 (c @@ ForAllTy_Var) v <*> apply t2 (addForallBinding v c @@ ForAllTy_Body) ty _ -> fail "not a forall type." {-# INLINE forAllTyT #-} -- | Rewrite all children of a type of the form: @ForAllTy@ 'Var' 'Type' -forAllTyAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type +forAllTyAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type forAllTyAllR r1 r2 = forAllTyT r1 r2 ForAllTy {-# INLINE forAllTyAllR #-} -- | Rewrite any children of a type of the form: @ForAllTy@ 'Var' 'Type' -forAllTyAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type +forAllTyAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type forAllTyAnyR r1 r2 = unwrapAnyR $ forAllTyAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE forAllTyAnyR #-} -- | Rewrite one child of a type of the form: @ForAllTy@ 'Var' 'Type' -forAllTyOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type +forAllTyOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m Var -> Rewrite c m Type -> Rewrite c m Type forAllTyOneR r1 r2 = unwrapOneR $ forAllTyAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE forAllTyOneR #-} @@ -1075,24 +1076,24 @@ -- | Translate a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' -forAllCoT :: (ExtendPath c Crumb, AddBindings c, Monad m) => Translate c m TyVar a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b +forAllCoT :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Translate c m TyVar a1 -> Translate c m Coercion a2 -> (a1 -> a2 -> b) -> Translate c m Coercion b forAllCoT t1 t2 f = translate $ \ c -> \case ForAllCo v co -> f <$> apply t1 (c @@ ForAllCo_TyVar) v <*> apply t2 (addForallBinding v c @@ ForAllCo_Body) co _ -> fail "not a forall coercion." {-# INLINE forAllCoT #-} -- | Rewrite all children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' -forAllCoAllR :: (ExtendPath c Crumb, AddBindings c, Monad m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion +forAllCoAllR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, Monad m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion forAllCoAllR r1 r2 = forAllCoT r1 r2 ForAllCo {-# INLINE forAllCoAllR #-} -- | Rewrite any children of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' -forAllCoAnyR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion +forAllCoAnyR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion forAllCoAnyR r1 r2 = unwrapAnyR $ forAllCoAllR (wrapAnyR r1) (wrapAnyR r2) {-# INLINE forAllCoAnyR #-} -- | Rewrite one child of a coercion of the form: @ForAllCo@ 'TyVar' 'Coercion' -forAllCoOneR :: (ExtendPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion +forAllCoOneR :: (ExtendPath c Crumb, ReadPath c Crumb, AddBindings c, MonadCatch m) => Rewrite c m TyVar -> Rewrite c m Coercion -> Rewrite c m Coercion forAllCoOneR r1 r2 = unwrapOneR $ forAllCoAllR (wrapOneR r1) (wrapOneR r2) {-# INLINE forAllCoOneR #-} diff --git a/src/HERMIT/Optimize.hs b/src/HERMIT/Optimize.hs --- a/src/HERMIT/Optimize.hs +++ b/src/HERMIT/Optimize.hs @@ -15,6 +15,7 @@ , phase , after , before + , until , allPhases , firstPhase , lastPhase @@ -26,6 +27,7 @@ , omToIO ) where +import Control.Applicative import Control.Arrow import Control.Concurrent.STM import Control.Monad.Error hiding (guard) @@ -51,6 +53,8 @@ import HERMIT.Shell.Command import HERMIT.Shell.Types +import Prelude hiding (until) + import System.Console.Haskeline (defaultBehavior) data OInst :: * -> * where @@ -61,7 +65,7 @@ Query :: (Injection ModGuts g, Walker HermitC g) => TranslateH g a -> OInst a newtype OM a = OM (ProgramT OInst (ReaderT PhaseInfo (CLM IO)) a) - deriving (Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO) optimize :: ([CommandLineOption] -> OM ()) -> Plugin optimize f = hermitPlugin $ \ phaseInfo -> runOM phaseInfo . f @@ -79,6 +83,7 @@ , cl_running_script = False , cl_tick = tick , cl_corelint = False + , cl_diffonly = False , cl_failhard = False , cl_window = mempty , cl_dict = error "cl_dict" -- TODO @@ -198,6 +203,9 @@ before cp = guard (\phaseInfo -> case phasesLeft phaseInfo of (x:_) | cp == x -> True _ -> False) + +until :: CorePass -> OM () -> OM () +until cp = guard ((cp `elem`) . phasesLeft) allPhases :: OM () -> OM () allPhases = guard (const True) diff --git a/src/HERMIT/Plugin.hs b/src/HERMIT/Plugin.hs --- a/src/HERMIT/Plugin.hs +++ b/src/HERMIT/Plugin.hs @@ -6,6 +6,7 @@ , getCorePass , ghcPasses , PhaseInfo(..) + , getPhaseFlag ) where import Data.List @@ -26,7 +27,7 @@ -- This is a bit of a hack; otherwise we lose what we've not seen liftIO $ hSetBuffering stdout NoBuffering - + let todos' = flattenTodos todos passes = map getCorePass todos' allPasses = foldr (\ (n,p,seen,notyet) r -> mkPass n seen notyet : p : r) @@ -47,7 +48,14 @@ -- | Filter options to those pertaining to this module, stripping module prefix. filterOpts :: [CommandLineOption] -> ModGuts -> [CommandLineOption] -filterOpts opts guts = [ drop len nm | nm <- opts, modName `isPrefixOf` nm ] +filterOpts opts guts = [ opt | nm <- opts + , let mopt = if modName `isPrefixOf` nm + then Just (drop len nm) + else if "*:" `isPrefixOf` nm + then Just (drop 2 nm) + else Nothing + , Just opt <- [mopt] + ] where modName = moduleNameString $ moduleName $ mg_module guts len = length modName + 1 -- for the colon @@ -133,3 +141,10 @@ , phasesLeft :: [CorePass] } deriving (Read, Show, Eq) + +-- | If HERMIT user specifies the -pN flag, get the N +-- TODO: as written will discard other flags that start with -p +getPhaseFlag :: [CommandLineOption] -> Maybe (Int, [CommandLineOption]) +getPhaseFlag opts = case partition ("-p" `isPrefixOf`) opts of + ([],_) -> Nothing + (ps,r) -> Just (read (drop 2 (last ps)), r) diff --git a/src/HERMIT/PrettyPrinter/Clean.hs b/src/HERMIT/PrettyPrinter/Clean.hs --- a/src/HERMIT/PrettyPrinter/Clean.hs +++ b/src/HERMIT/PrettyPrinter/Clean.hs @@ -215,6 +215,15 @@ ppVar :: PrettyH Var ppVar = readerT $ \ v -> varName ^>> ppName (varColor v) +-- For var occurences (in CoreExpr) +ppVarOcc :: PrettyH Var +ppVarOcc = do + (c,i) <- exposeT + let colFn = if isDeadBinder i || (isLocalId i && (i `notElemVarSet` boundVars c)) + then const WarningColor + else varColor + markBindingSite i c <$> (readerT $ \ v -> varName ^>> ppName (colFn v)) + varColor :: Var -> SyntaxForColor varColor var | isTyVar var = TypeColor | isCoVar var = CoercionColor @@ -331,14 +340,7 @@ <+ letT ppCoreBind ppCoreExprR (retLet p) <+ appT ppCoreExprR ppCoreExprR (retApp p App_Fun App_Arg) <+ caseT ppCoreExpr ppVar (ppTypeModeR >>> parenExpr) (const ppCoreAlt) (\ s w ty alts -> RetExpr ((keyword p "case" <+> s <+> keyword p "of" <+> w <+> ty) $$ nest 2 (vcat alts))) - - <+ varT (do (c,i) <- exposeT - RetAtom <$> if isDeadBinder i || - (isLocalId i && (i `notElemVarSet` boundVars c)) - then varName ^>> ppName WarningColor - else ppVar - ) - + <+ varT (RetAtom <$> ppVarOcc) <+ litT (RetAtom <$> ppSDoc) <+ typeT ppTypeModeR <+ coercionT ppCoercionModeR @@ -366,7 +368,7 @@ where ppKindOrTypePR :: AbsolutePathH -> Translate PrettyC HermitM KindOrType RetExpr ppKindOrTypePR p = - tyVarT (RetAtom <$> ppVar) + tyVarT (RetAtom <$> ppVarOcc) <+ litTyT (RetAtom <$> ppLitTy) <+ appTyT ppKindOrTypeR ppKindOrTypeR (retApp p AppTy_Fun AppTy_Arg) <+ funTyT ppKindOrTypeR ppKindOrTypeR (retArrowType p FunTy_Dom FunTy_CoDom) @@ -405,7 +407,7 @@ where ppCoercionPR :: AbsolutePathH -> Translate PrettyC HermitM Coercion RetExpr ppCoercionPR p = - coVarCoT (RetAtom <$> ppVar) + coVarCoT (RetAtom <$> ppVarOcc) <+ symCoT (ppCoercionR >>> parenExpr >>^ \ co -> RetExpr (coKeyword p "sym" <+> co)) <+ forAllCoT ppBinderMode ppCoercionR (retForAll p ForAllCo_Body) <+ transCoT (ppCoercionR >>> parenExprExceptApp) (ppCoercionR >>> parenExprExceptApp) (\ co1 co2 -> RetExpr (co1 <+> coChar p ';' <+> co2)) diff --git a/src/HERMIT/PrettyPrinter/Common.hs b/src/HERMIT/PrettyPrinter/Common.hs --- a/src/HERMIT/PrettyPrinter/Common.hs +++ b/src/HERMIT/PrettyPrinter/Common.hs @@ -10,6 +10,7 @@ , coercionColor , idColor , keywordColor + , markBindingSite , markColor , typeColor , ShowOption(..) @@ -86,8 +87,9 @@ deriving Show -- These are the attributes -data Attr = PathAttr AbsolutePathH - | Color SyntaxForColor +data Attr = BndrAttr AbsolutePathH -- path to binding of a variable + | Color SyntaxForColor + | PathAttr AbsolutePathH -- path to this spot | SpecialFont deriving (Eq, Show) @@ -129,11 +131,16 @@ -- TODO: change monads to something more restricted? -- | Context for PrettyH translations. -data PrettyC = PrettyC { prettyC_path :: AbsolutePath Crumb - , prettyC_vars :: VarSet +data PrettyC = PrettyC { prettyC_path :: AbsolutePathH + , prettyC_vars :: M.Map Var AbsolutePathH , prettyC_options :: PrettyOptions } +markBindingSite :: Var -> PrettyC -> DocH -> DocH +markBindingSite i c d = case M.lookup i (prettyC_vars c) of + Nothing -> d + Just p -> attr (BndrAttr p) d + ------------------------------------------------------------------------ instance ReadPath PrettyC Crumb where @@ -147,23 +154,13 @@ {-# INLINE (@@) #-} instance AddBindings PrettyC where - addHermitBindings :: [(Var,HermitBindingSite)] -> PrettyC -> PrettyC - addHermitBindings vbs c = c { prettyC_vars = foldr (flip extendVarSet) (prettyC_vars c) (map fst vbs) } - -- let vhbs = [ (v, (0,b)) | (v,b) <- vbs ] -- TODO: do we care about depth? - -- in c { prettyC_bindings = M.fromList vhbs `M.union` prettyC_bindings c } + addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> PrettyC -> PrettyC + addHermitBindings vbs c = c { prettyC_vars = M.union (prettyC_vars c) (M.fromList [ (i,p) | (i,_,p) <- vbs ]) } {-# INLINE addHermitBindings #-} --- instance ReadBindings PrettyC where --- hermitDepth :: PrettyC -> BindingDepth --- hermitDepth = prettyC_depth - --- hermitBindings :: PrettyC -> M.Map Var HermitBinding --- hermitBindings = prettyC_bindings --- {-# INLINE hermitBindings #-} - instance BoundVars PrettyC where boundVars :: PrettyC -> VarSet - boundVars = prettyC_vars + boundVars = mkVarSet . M.keys . prettyC_vars ------------------------------------------------------------------------ @@ -172,13 +169,13 @@ liftPrettyC :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> c -> PrettyC liftPrettyC opts c = PrettyC { prettyC_path = absPath c - , prettyC_vars = boundVars c + , prettyC_vars = M.fromList [ (i,hbPath b) | (i,b) <- M.toList (hermitBindings c) ] , prettyC_options = opts} initPrettyC :: PrettyOptions -> PrettyC initPrettyC opts = PrettyC { prettyC_path = mempty - , prettyC_vars = emptyVarSet + , prettyC_vars = M.empty , prettyC_options = opts } diff --git a/src/HERMIT/Shell/Command.hs b/src/HERMIT/Shell/Command.hs --- a/src/HERMIT/Shell/Command.hs +++ b/src/HERMIT/Shell/Command.hs @@ -36,7 +36,7 @@ import HERMIT.External import qualified HERMIT.GHC as GHC import HERMIT.Interp -import HERMIT.Kernel (queryK) +import HERMIT.Kernel (queryK, AST) import HERMIT.Kernel.Scoped hiding (abortS, resumeS) import HERMIT.Kure import HERMIT.Monad @@ -94,7 +94,7 @@ focusPath <- getFocusPath let skernel = cl_kernel st ppOpts = (cl_pretty_opts st) { po_focus = Just focusPath } - -- No not show focus while loading + -- Do not show focus while loading ifM (gets cl_running_script) (return ()) (iokm2clm' "Rendering error: " @@ -209,6 +209,7 @@ , cl_dict = dict , cl_pretty_opts = (cl_pretty_opts initState) { po_width = w } , cl_height = h + , cl_initSAST = cl_cursor initState } put clState @@ -276,6 +277,14 @@ fail (interpExprH dict interpShellCommand expr) +ppWholeProgram :: MonadIO m => AST -> CLM m DocH +ppWholeProgram ast = do + st <- get + liftIO (queryK (kernelS $ cl_kernel st) + ast + (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ cl_pretty st) + (cl_kernel_env st)) >>= runKureM return fail + ------------------------------------------------------------------------------- -- TODO: This can be refactored. We always showWindow. Also, Perhaps return a modifier, not () @@ -288,10 +297,16 @@ let sk = cl_kernel st kEnv = cl_kernel_env st + sast = cl_cursor st + ppOpts = cl_pretty_opts st - sast' <- prefixFailMsg "Rewrite failed: " $ applyS sk rr kEnv (cl_cursor st) + sast' <- prefixFailMsg "Rewrite failed: " $ applyS sk rr kEnv sast - let commit = put (newSAST expr sast' st) >> showWindow + let commit = put (newSAST expr sast' st) >> showResult + showResult = if cl_diffonly st then showDiff else showWindow + showDiff = do doc1 <- queryS sk (liftPrettyH ppOpts (cl_pretty st)) kEnv sast + doc2 <- queryS sk (liftPrettyH ppOpts (cl_pretty st)) kEnv sast' + diffDocH ppOpts doc1 doc2 >>= cl_putStr if cl_corelint st then do ast' <- toASTS sk sast' @@ -388,11 +403,7 @@ ast1 <- toASTS (cl_kernel st) s1 ast2 <- toASTS (cl_kernel st) s2 - let getDoc ast = liftIO (queryK (kernelS $ cl_kernel st) - ast - (extractT $ pathT [ModGuts_Prog] $ liftPrettyH (cl_pretty_opts st) $ cl_pretty st) - (cl_kernel_env st)) >>= runKureM return fail - getCmds sast | sast == s1 = [] + let getCmds sast | sast == s1 = [] | otherwise = case [ (f,c) | (f,c,to) <- vs_graph (cl_version st), to == sast ] of [(sast',cmd)] -> unparseExprH cmd : getCmds sast' _ -> ["error: history broken!"] -- should be impossible @@ -401,8 +412,8 @@ cl_putStrLn "=========" cl_putStrLn $ unlines $ reverse $ getCmds s2 - doc1 <- getDoc ast1 - doc2 <- getDoc ast2 + doc1 <- ppWholeProgram ast1 + doc2 <- ppWholeProgram ast2 r <- diffDocH (cl_pretty_opts st) doc1 doc2 diff --git a/src/HERMIT/Shell/Externals.hs b/src/HERMIT/Shell/Externals.hs --- a/src/HERMIT/Shell/Externals.hs +++ b/src/HERMIT/Shell/Externals.hs @@ -89,6 +89,12 @@ [ "tag