git.iko.soy/elk
on e28d01e help sign in
elk/src/Optimize/Environment.hs
192 lines 4.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Optimize.Environment
4 ( Optimizer, run
5 , Env
6 , getVariantDict
7 , getHome
8 , getTailCall, setTailCall
9 , freshName
10 , register
11 , registerEffects
12 , indirectly
13 )
14 where
16import qualified Control.Monad.State.Strict as State
17import Data.Monoid ((<>))
18import qualified Data.Set as Set
19import qualified Data.Text as Text
20import Data.Text (Text)
22import qualified AST.Effects as Effects
23import qualified AST.Expression.Optimized as Opt
24import qualified AST.Module.Name as ModuleName
25import qualified AST.Variable as Var
26import qualified Optimize.DecisionTree as DT
30-- ENVIRONMENT
33data Env =
34 Env
35 { _read_only_variants :: !DT.VariantDict
36 , _read_only_home :: !ModuleName.Canonical
37 , _uid :: !Int
38 , _deps :: Deps
39 , _effects :: Maybe Effects.ManagerType
40 , _has_tail_call :: !Bool
41 }
45-- DEPS
48data Deps
49 = Direct { _direct :: Set.Set Var.Global, _indirect :: Set.Set Var.Global }
50 | Indirect (Set.Set Var.Global)
53emptyDeps :: Deps
54emptyDeps =
55 Direct Set.empty Set.empty
58insertDep :: Var.Global -> Deps -> Deps
59insertDep var deps =
60 case deps of
61 Direct direct indirect ->
62 Direct (Set.insert var direct) indirect
64 Indirect indirect ->
65 Indirect (Set.insert var indirect)
68unionDeps :: Set.Set Var.Global -> Deps -> Deps
69unionDeps vars deps =
70 case deps of
71 Direct direct indirect ->
72 Direct (Set.union vars direct) indirect
74 Indirect indirect ->
75 Indirect (Set.union vars indirect)
79-- OPTIMIZER
82type Optimizer a =
83 State.State Env a
86run
87 :: DT.VariantDict
88 -> ModuleName.Canonical
89 -> Optimizer (Text, Opt.Def)
90 -> (Text, Opt.Decl)
91run variantDict home optimizer =
92 let
93 ((name, def), Env _ _ _ (Direct direct indirect) fx _) =
94 State.runState optimizer $
95 Env variantDict home 0 emptyDeps Nothing False
96 in
97 ( name, Opt.Decl direct indirect fx def )
101-- READ ONLY
104getVariantDict :: Optimizer DT.VariantDict
105getVariantDict =
106 State.gets _read_only_variants
109getHome :: Optimizer ModuleName.Canonical
110getHome =
111 State.gets _read_only_home
115-- TAIL CALLS
118getTailCall :: Optimizer Bool
119getTailCall =
120 State.gets _has_tail_call
123setTailCall :: Bool -> Optimizer ()
124setTailCall bool =
125 do env <- State.get
126 State.put (env { _has_tail_call = bool })
130-- FRESH VARIABLES
133freshName :: Optimizer Text
134freshName =
135 do (Env vs home uid deps fx htc) <- State.get
136 State.put (Env vs home (uid + 1) deps fx htc)
137 return ("_p" <> Text.pack (show uid))
141-- REGISTER DEPENDENCIES
144register :: Var.Global -> Optimizer ()
145register global =
146 State.modify' (registerHelp global)
149registerHelp :: Var.Global -> Env -> Env
150registerHelp dep (Env vs home uid deps fx htc) =
151 Env vs home uid (insertDep dep deps) fx htc
154indirectly :: Optimizer a -> Optimizer a
155indirectly optimizer =
156 do (Env vs home uid deps fx htc) <- State.get
157 case deps of
158 Indirect _ ->
159 optimizer
161 Direct direct indirect ->
162 do State.put (Env vs home uid (Indirect indirect) fx htc)
163 result <- optimizer
164 (Env vs_ home_ uid_ (Indirect indirect_) fx_ htc_) <- State.get
165 State.put (Env vs_ home_ uid_ (Direct direct indirect_) fx_ htc_)
166 return result
170-- REGISTER EFFECTS
173registerEffects :: ModuleName.Canonical -> Effects.ManagerType -> Optimizer Effects.ManagerType
174registerEffects home manager =
175 do (Env vs hm uid deps _ htc) <- State.get
176 let newDeps = unionDeps (getEffectDeps home manager) deps
177 State.put (Env vs hm uid newDeps (Just manager) htc)
178 return manager
181getEffectDeps :: ModuleName.Canonical -> Effects.ManagerType -> Set.Set Var.Global
182getEffectDeps home manager =
183 Set.fromList $ map (Var.Global home) $
184 case manager of
185 Effects.Cmds ->
186 [ "init", "onEffects", "onSelfMsg", "cmdMap" ]
188 Effects.Subs ->
189 [ "init", "onEffects", "onSelfMsg", "subMap" ]
191 Effects.Both ->
192 [ "init", "onEffects", "onSelfMsg", "cmdMap", "subMap" ]