# strict-ghc-plugin / Strict / Pass.lhs

  1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 \begin{code} {-# LANGUAGE PatternGuards #-} module Strict.Pass (strictifyProgram) where 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 :: ModGuts -> CoreM ModGuts strictifyProgram guts = do newBinds <- mapM (strictifyFunc guts) (mg_binds guts) return $guts { mg_binds = newBinds } 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) | Type _ <- e1 = return e -- Yes, this can occur! | otherwise = return$ Case e1 b (exprType e2) [(DEFAULT, [], e2)] strictifyExpr e@(App e1 e2) = case e2 of App _ _ -> translate Case _ _ _ _ -> translate Cast _ _ -> translate -- May as well, these two don't Tick _ _ -> translate -- appear on types anyway _ -> return e -- N.b. don't need to consider lets since they will have been eliminated already where translate = do b <- mkSysLocalM (fsLit "strict") (exprType e2) return $Case e2 b (exprType e) [(DEFAULT, [], App e1 (Var b))] strictifyExpr e = return e \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}