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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
module GHC.StgToJS.Sinker (sinkPgm) where
import GHC.Prelude
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Var.Set
import GHC.Stg.Syntax
import GHC.Types.Id
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Types.Literal
import GHC.Data.Graph.Directed
import GHC.StgToJS.CoreUtils
import Data.Char
import Data.Either
import Data.List (partition)
import Data.Maybe
-- | Unfloat some top-level unexported things
--
-- GHC floats constants to the top level. This is fine in native code, but with JS
-- they occupy some global variable name. We can unfloat some unexported things:
--
-- - global constructors, as long as they're referenced only once by another global
-- constructor and are not in a recursive binding group
-- - literals (small literals may also be sunk if they are used more than once)
sinkPgm :: Module
-> [CgStgTopBinding]
-> (UniqFM Id CgStgExpr, [CgStgTopBinding])
sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits)
where
selectLifted (StgTopLifted b) = Left b
selectLifted x = Right x
(pgm', stringLits) = partitionEithers (map selectLifted pgm)
(sunk, pgm'') = sinkPgm' m pgm'
sinkPgm'
:: Module
-- ^ the module, since we treat definitions from the current module
-- differently
-> [CgStgBinding]
-- ^ the bindings
-> (UniqFM Id CgStgExpr, [CgStgBinding])
-- ^ a map with sunken replacements for nodes, for where the replacement
-- does not fit in the 'StgBinding' AST and the new bindings
sinkPgm' m pgm =
let usedOnce = collectUsedOnce pgm
sinkables = listToUFM $
concatMap alwaysSinkable pgm ++
filter ((`elementOfUniqSet` usedOnce) . fst) (concatMap (onceSinkable m) pgm)
isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True
isSunkBind _ = False
in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm)
-- | always sinkable, values that may be duplicated in the generated code (e.g.
-- small literals)
alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)]
alwaysSinkable (StgRec {}) = []
alwaysSinkable (StgNonRec b rhs) = case rhs of
StgRhsClosure _ _ _ _ e@(StgLit l) _
| isSmallSinkableLit l
, isLocal b
-> [(b,e)]
StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l] _typ
| isSmallSinkableLit l
, isLocal b
, isUnboxableCon dc
-> [(b,StgConApp dc cnum as [])]
_ -> []
isSmallSinkableLit :: Literal -> Bool
isSmallSinkableLit (LitChar c) = ord c < 100000
isSmallSinkableLit (LitNumber _ i) = abs i < 100000
isSmallSinkableLit _ = False
-- | once sinkable: may be sunk, but duplication is not ok
onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)]
onceSinkable _m (StgNonRec b rhs)
| Just e <- getSinkable rhs
, isLocal b = [(b,e)]
where
getSinkable = \case
StgRhsCon _ccs dc cnum _ticks args _typ -> Just (StgConApp dc cnum args [])
StgRhsClosure _ _ _ _ e@(StgLit{}) _typ -> Just e
_ -> Nothing
onceSinkable _ _ = []
-- | collect all idents used only once in an argument at the top level
-- and never anywhere else
collectUsedOnce :: [CgStgBinding] -> IdSet
collectUsedOnce binds = intersectUniqSets (usedOnce args) (usedOnce top_args)
where
top_args = concatMap collectArgsTop binds
args = concatMap collectArgs binds
usedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet)
g i t@(once, mult)
| i `elementOfUniqSet` mult = t
| i `elementOfUniqSet` once
= (delOneFromUniqSet once i, addOneToUniqSet mult i)
| otherwise = (addOneToUniqSet once i, mult)
-- | fold over all id in StgArg used at the top level in an StgRhsCon
collectArgsTop :: CgStgBinding -> [Id]
collectArgsTop = \case
StgNonRec _b r -> collectArgsTopRhs r
StgRec bs -> concatMap (collectArgsTopRhs . snd) bs
collectArgsTopRhs :: CgStgRhs -> [Id]
collectArgsTopRhs = \case
StgRhsCon _ccs _dc _mu _ticks args _typ -> concatMap collectArgsA args
StgRhsClosure {} -> []
-- | fold over all Id in StgArg in the AST
collectArgs :: CgStgBinding -> [Id]
collectArgs = \case
StgNonRec _b r -> collectArgsR r
StgRec bs -> concatMap (collectArgsR . snd) bs
collectArgsR :: CgStgRhs -> [Id]
collectArgsR = \case
StgRhsClosure _x0 _x1 _x2 _x3 e _typ -> collectArgsE e
StgRhsCon _ccs _con _mu _ticks args _typ -> concatMap collectArgsA args
collectArgsAlt :: CgStgAlt -> [Id]
collectArgsAlt alt = collectArgsE (alt_rhs alt)
collectArgsE :: CgStgExpr -> [Id]
collectArgsE = \case
StgApp x args
-> x : concatMap collectArgsA args
StgConApp _con _mn args _ts
-> concatMap collectArgsA args
StgOpApp _x args _t
-> concatMap collectArgsA args
StgCase e _b _a alts
-> collectArgsE e ++ concatMap collectArgsAlt alts
StgLet _x b e
-> collectArgs b ++ collectArgsE e
StgLetNoEscape _x b e
-> collectArgs b ++ collectArgsE e
StgTick _i e
-> collectArgsE e
StgLit _
-> []
collectArgsA :: StgArg -> [Id]
collectArgsA = \case
StgVarArg i -> [i]
StgLitArg _ -> []
isLocal :: Id -> Bool
isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i)
-- | since we have sequential initialization, topsort the non-recursive
-- constructor bindings
topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding]
topSortDecls _m binds = rest ++ nr'
where
(nr, rest) = partition isNonRec binds
isNonRec StgNonRec{} = True
isNonRec _ = False
vs = map getV nr
keys = mkUniqSet (map node_key vs)
getV e@(StgNonRec b _) = DigraphNode e b []
getV _ = error "topSortDecls: getV, unexpected binding"
collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args _typ)) =
[ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ]
collectDeps _ = []
g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr)
nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g]
= error "topSortDecls: unexpected cycle"
| otherwise = map node_payload (topologicalSortG g)
|
