Commits

austin s  committed 97a9624

make strictify pass use annotations instead of blindly strictifying whole modules

  • Participants
  • Parent commits 6c4ddd8

Comments (0)

Files changed (5)

File Strict/Annotation.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+module Strict.Annotation where
+import Data.Data
+
+-- | Programs which want to 'strictify' their functions should annotate them with the following
+-- datatype
+-- TODO: move this into a separate package perhaps?
+data Strictify = Strictify deriving (Typeable, Data)

File Strict/Pass.lhs

 
 import GHCPlugins
 
+import Control.Monad
 import Data.Generics
 import Data.Maybe
 
+import Strict.Annotation
+
 \end{code}
+Strictification of a program based on annotations.
 \begin{code}
 
-strictifyProgram :: [CoreBind] -> CoreM [CoreBind]
-strictifyProgram binds = everywhereM (mkM strictifyExpr) binds
+strictifyProgram :: ModGuts -> CoreM [CoreBind]
+strictifyProgram guts = mapM (strictifyFunc guts) (mg_binds guts)
+
+strictifyFunc :: ModGuts -> CoreBind -> CoreM CoreBind
+strictifyFunc guts x@(NonRec b e) = do 
+  b <- shouldStrictify guts b
+  case b of
+    True -> everywhereM (mkM strictifyExpr) x
+    False -> return x
+strictifyFunc guts x@(Rec bes) = do
+  b <- (not . null) `liftM` (filterM (shouldStrictify guts . fst) bes)
+  if b then everywhereM (mkM strictifyExpr) x
+    else return x
 
 strictifyExpr :: CoreExpr -> CoreM CoreExpr
 strictifyExpr e@(Let (NonRec b e1) e2) 
             return $ Case e2 b (exprType e) [(DEFAULT, [], App e1 (Var b))]
 strictifyExpr e = return e
 
-\end{code}
+\end{code}
+Utilities and other miscellanious stuff
+\begin{code}
+
+shouldStrictify :: ModGuts -> CoreBndr -> CoreM Bool
+shouldStrictify guts bndr = do
+  l <- annotationsOn guts bndr :: CoreM [Strictify]
+  return $ not $ null l
+
+annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]
+annotationsOn guts bndr = do
+  anns <- getAnnotations deserializeWithData guts
+  return $ lookupWithDefaultUFM anns [] (varUnique bndr)
+
+\end{code}

File Strict/Plugin.hs

-module Strict.Plugin where
+module Strict.Plugin (plugin) where
 
 import Strict.Pass
 
 
 install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
 install _option todos = do
-    return $ CoreDoPluginPass "Strictify" (BindsToBindsPluginPass strictifyProgram) : todos
+    return $ CoreDoPluginPass "Strictify" (ModGutsToBindsPluginPass strictifyProgram) : todos

File strict-plugin.cabal

 Library
     Exposed-Modules:
         Strict.Plugin
+        Strict.Annotation
     Other-Modules:
         Strict.Pass
     Build-Depends:

File tests/NonTerminating.hs

 {-# LANGUAGE CPP #-}
 module Main ( main ) where
-
-#ifdef USE_CHASING_BOTTOMS
-
-import Test.ChasingBottoms
-
-evaluate_and_possibly_timeout what = do
-    result <- timeOut'
-    case result of
-            NonTermination -> putStrLn "Test successful"
-            Value val -> putStrLn $ "Test failed due to the thing compiled terminating with value: " ++ show val
-
-#else
+import Strict.Annotation
 
 import Control.Exception ( evaluate )
 
     val <- evaluate what
     putStrLn $ "Test failed due to the thing compiled terminating with value: " ++ show val
 
-#endif
-
+{-# ANN foreverFrom Strictify #-}
 foreverFrom :: Int -> [Int]
 foreverFrom n = n : foreverFrom (n + 1)