git.iko.soy/reflex
on ae@dev-script help sign in
reflex/src/Reflex/Optimizer.hs
65 lines 2.0 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE OverloadedStrings #-}
4-- |
5-- Module:
6-- Reflex.Optimizer
7-- Description:
8-- This module provides a GHC plugin designed to improve code that uses
9-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level
10-- definition that doesn't have an explicit inlining pragma. In the future,
11-- additional optimizations are likely to be added.
12module Reflex.Optimizer
13 ( plugin
14 ) where
16#ifdef ghcjs_HOST_OS
17import Plugins
18#else
19import Control.Arrow
20import CoreMonad
21import Data.String
22import GhcPlugins
24#if MIN_VERSION_base(4,9,0)
25import Prelude hiding ((<>))
26#endif
28#endif
30#ifdef ghcjs_HOST_OS
32-- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used.
33plugin :: Plugin
34plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS."
36#else
38-- | The GHC plugin itself. See "GhcPlugins" for more details.
39plugin :: Plugin
40plugin = defaultPlugin { installCoreToDos = install }
42install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
43install [] p = do
44 liftIO $ putStrLn $ showSDocUnsafe $ ppr p
45 let f = \case
46 simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl]
47 x -> [x]
48 return $ makeInlinable : concatMap f p
49install options@(_:_) p = do
50 warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"
51 install [] p
53makeInlinable :: CoreToDo
54makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do
55 let f v = setIdInfo v $ let i = idInfo v in
56 setInlinePragInfo i $ let p = inlinePragInfo i in
57 if isDefaultInlinePragma p
58 then defaultInlinePragma { inl_inline = Inlinable }
59 else p
60 newBinds = flip map (mg_binds modGuts) $ \case
61 NonRec b e -> NonRec (f b) e
62 Rec bes -> Rec $ map (first f) bes
63 return $ modGuts { mg_binds = newBinds }
65#endif