PageRenderTime 54ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 0ms

/src/Gen2/RtsTypes.hs

http://github.com/ghcjs/ghcjs
Haskell | 822 lines | 589 code | 155 blank | 78 comment | 30 complexity | 69ad65ddeeec83a0d7f311d167d6acf9 MD5 | raw file
Possible License(s): BSD-3-Clause, Apache-2.0
  1. {-# LANGUAGE CPP,
  2. QuasiQuotes,
  3. TemplateHaskell,
  4. TypeSynonymInstances,
  5. FlexibleInstances,
  6. TupleSections,
  7. OverloadedStrings #-}
  8. module Gen2.RtsTypes where
  9. import DynFlags
  10. import Encoding
  11. import Id
  12. import Module
  13. import Name
  14. import Outputable hiding ((<>))
  15. import StgSyn
  16. import Unique
  17. import UniqFM
  18. import SrcLoc
  19. import ForeignCall (Safety(..), CCallConv(..))
  20. import FastString
  21. import qualified Control.Exception as Ex
  22. import Control.Lens
  23. import Control.Monad.State.Strict
  24. import Data.Array (Array, (!), listArray)
  25. import Data.Bits
  26. import Data.Char (toLower)
  27. import Data.Default
  28. import Data.Ix
  29. import qualified Data.List as L
  30. import qualified Data.Map as M
  31. import Data.Maybe (fromMaybe, isJust)
  32. import Data.Set (Set)
  33. import qualified Data.Set as S
  34. import Data.Text (Text)
  35. import qualified Data.Text as T
  36. import Compiler.Compat
  37. import Compiler.JMacro
  38. import Compiler.Utils
  39. import Gen2.ClosureInfo
  40. import Gen2.Utils
  41. traceRts :: ToJExpr a => CgSettings -> a -> JStat
  42. traceRts s e = jStatIf (csTraceRts s) [j| h$log(`e`); |]
  43. assertRts :: ToJExpr a => CgSettings -> JExpr -> a -> JStat
  44. assertRts s e m = jStatIf (csAssertRts s) [j| if(!`e`) { throw `m`; } |]
  45. jStatIf :: Bool -> JStat -> JStat
  46. jStatIf True s = s
  47. jStatIf _ _ = mempty
  48. clName :: JExpr -> JExpr
  49. clName c = [je| `c`.n |]
  50. clTypeName :: JExpr -> JExpr
  51. clTypeName c = [je| h$closureTypeName(`c`.t) |]
  52. infixr 1 |+
  53. infixr 1 |-
  54. infixl 3 |.
  55. infixl 2 |!
  56. infixl 2 |!!
  57. -- a + b
  58. (|+) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  59. (|+) e1 e2 = [je| `e1` + `e2` |]
  60. -- a - b
  61. (|-) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  62. (|-) e1 e2 = [je| `e1` - `e2` |]
  63. -- a & b
  64. (|&) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  65. (|&) e1 e2 = [je| `e1` & `e2` |]
  66. -- a.b
  67. (|.) :: ToJExpr a => a -> Text -> JExpr
  68. (|.) e i = SelExpr (toJExpr e) (TxtI i)
  69. -- a[b]
  70. (|!) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  71. (|!) e i = [je| `e`[`i`] |]
  72. -- a[b] with b int
  73. (|!!) :: ToJExpr a => a -> Int -> JExpr
  74. (|!!) = (|!)
  75. -- a(b1,b2,...)
  76. (|^) :: ToJExpr a => a -> [JExpr] -> JExpr
  77. (|^) a bs = ApplExpr (toJExpr a) bs
  78. (|^^) :: Text -> [JExpr] -> JExpr
  79. (|^^) a bs = ApplExpr (jsv a) bs
  80. (|||) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  81. (|||) a b = [je| `a` || `b` |]
  82. (|&&) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  83. (|&&) a b = [je| `a` && `b` |]
  84. (|===) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  85. (|===) a b = [je| `a` === `b` |]
  86. (|!==) :: (ToJExpr a, ToJExpr b) => a -> b -> JExpr
  87. (|!==) a b = [je| `a` !== `b` |]
  88. infix 7 |=
  89. (|=) :: ToJExpr a => Ident -> a -> JStat
  90. (|=) i b = AssignStat (toJExpr i) (toJExpr b)
  91. infix 7 ||=
  92. (||=) :: ToJExpr a => Ident -> a -> JStat
  93. (||=) i b = decl i <> i |= b
  94. showPpr' :: Outputable a => a -> G String
  95. showPpr' a = do
  96. df <- _gsDynFlags <$> get
  97. return (showPpr df a)
  98. showSDoc' :: SDoc -> G String
  99. showSDoc' a = do
  100. df <- _gsDynFlags <$> get
  101. return (showSDoc df a)
  102. -- fixme this is getting out of hand...
  103. data StgReg = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8
  104. | R9 | R10 | R11 | R12 | R13 | R14 | R15 | R16
  105. | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24
  106. | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32
  107. | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40
  108. | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48
  109. | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56
  110. | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64
  111. | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72
  112. | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80
  113. | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88
  114. | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96
  115. | R97 | R98 | R99 | R100 | R101 | R102 | R103 | R104
  116. | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112
  117. | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120
  118. | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128
  119. deriving (Eq, Ord, Show, Enum, Bounded, Ix)
  120. -- | return registers
  121. -- extra results from foreign calls can be stored here (first result is returned)
  122. data StgRet = Ret1 | Ret2 | Ret3 | Ret4 | Ret5 | Ret6 | Ret7 | Ret8 | Ret9 | Ret10
  123. deriving (Eq, Ord, Show, Enum, Bounded, Ix)
  124. instance ToJExpr StgReg where
  125. toJExpr = (registers!)
  126. -- only the registers that have a single ident
  127. registersI :: Array StgReg Ident
  128. registersI = listArray (minBound, R32) (map (ri.(registers!)) $ enumFromTo R1 R32)
  129. where
  130. ri (ValExpr (JVar i)) = i
  131. ri _ = error "registersI: not an ident"
  132. registers :: Array StgReg JExpr
  133. registers = listArray (minBound, maxBound) (map regN (enumFrom R1))
  134. where
  135. regN r
  136. | fromEnum r < 32 = ValExpr . JVar . TxtI . T.pack . ("h$"++) . map toLower . show $ r
  137. | otherwise = [je| h$regs[`fromEnum r-32`] |]
  138. instance ToJExpr StgRet where
  139. toJExpr r = ValExpr (JVar (rets!r))
  140. rets :: Array StgRet Ident
  141. rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1))
  142. where
  143. retN = TxtI . T.pack . ("h$"++) . map toLower . show
  144. regName :: StgReg -> String
  145. regName = map toLower . show
  146. regNum :: StgReg -> Int
  147. regNum r = fromEnum r + 1
  148. numReg :: Int -> StgReg
  149. numReg r = toEnum (r - 1)
  150. minReg :: Int
  151. minReg = regNum minBound
  152. maxReg :: Int
  153. maxReg = regNum maxBound
  154. data IdType = IdPlain | IdEntry | IdConEntry deriving (Enum, Eq, Ord, Show)
  155. data IdKey = IdKey !Int !Int !IdType deriving (Eq, Ord)
  156. newtype IdCache = IdCache (M.Map IdKey Ident)
  157. newtype GlobalIdCache = GlobalIdCache (M.Map Ident (IdKey, Id))
  158. emptyGlobalIdCache :: GlobalIdCache
  159. emptyGlobalIdCache = GlobalIdCache M.empty
  160. data OtherSymb = OtherSymb !Module !Text
  161. deriving (Ord, Eq, Show)
  162. emptyIdCache :: IdCache
  163. emptyIdCache = IdCache M.empty
  164. data GenState = GenState
  165. { _gsSettings :: CgSettings -- ^ codegen settings, read-only
  166. , _gsModule :: !Module -- ^ current module
  167. , _gsDynFlags :: DynFlags -- ^ dynamic flags
  168. , _gsId :: !Int -- ^ unique number for the id generator
  169. , _gsIdents :: !IdCache -- ^ hash consing for identifiers from a Unique
  170. , _gsUnfloated :: !(UniqFM StgExpr) -- ^ unfloated arguments
  171. , _gsGroup :: GenGroupState -- ^ state for the current binding group
  172. , _gsGlobal :: [JStat] -- ^ global (per module) statements (gets included when anything else from the module is used)
  173. }
  174. -- | the state relevant for the current binding group
  175. data GenGroupState = GenGroupState
  176. { _ggsToplevelStats :: [JStat] -- ^ extra toplevel statements for the binding group
  177. , _ggsClosureInfo :: [ClosureInfo] -- ^ closure metadata (info tables) for the binding group
  178. , _ggsStatic :: [StaticInfo] -- ^ static (CAF) data in our binding group
  179. , _ggsStack :: [StackSlot] -- ^ stack info for the current expression
  180. , _ggsStackDepth :: Int -- ^ current stack depth
  181. , _ggsExtraDeps :: Set OtherSymb -- ^ extra dependencies for the linkable unit that contains this group
  182. , _ggsGlobalIdCache :: GlobalIdCache
  183. , _ggsForeignRefs :: [ForeignRef]
  184. -- , _ggsGlobalRefs :: [[Id]]
  185. }
  186. instance Default GenGroupState where
  187. def = GenGroupState [] [] [] [] 0 S.empty emptyGlobalIdCache [] -- []
  188. type C = State GenState JStat
  189. type G = State GenState
  190. data StackSlot = SlotId !Id !Int
  191. | SlotUnknown
  192. deriving (Eq, Ord, Show)
  193. makeLenses ''GenGroupState
  194. makeLenses ''GenState
  195. assertRtsStat :: C -> C
  196. assertRtsStat stat = do
  197. s <- use gsSettings
  198. if csAssertRts s then stat else mempty
  199. -- | emit a global (for the current module) toplevel statement
  200. emitGlobal :: JStat -> G ()
  201. emitGlobal s = gsGlobal %= (s:)
  202. -- functions below modify the current binding group state
  203. -- | start with a new binding group
  204. resetGroup :: G ()
  205. resetGroup = gsGroup .= def
  206. -- | add a dependency on a particular symbol to the current group
  207. addDependency :: OtherSymb -> G ()
  208. addDependency symbol = gsGroup . ggsExtraDeps %= (S.insert symbol)
  209. -- | emit a top-level statement for the current binding group
  210. emitToplevel :: JStat -> G ()
  211. emitToplevel s = gsGroup . ggsToplevelStats %= (s:)
  212. -- | add closure info in our binding group. all heap objects must have closure info
  213. emitClosureInfo :: ClosureInfo -> G ()
  214. emitClosureInfo ci = gsGroup . ggsClosureInfo %= (ci:)
  215. -- | emit static data for the binding group
  216. emitStatic :: Text -> StaticVal -> Maybe Ident -> G ()
  217. emitStatic ident val cc = gsGroup . ggsStatic %= (StaticInfo ident val cc :)
  218. emitForeign :: Maybe RealSrcSpan
  219. -> Text
  220. -> Safety
  221. -> CCallConv
  222. -> [Text]
  223. -> Text
  224. -> G ()
  225. emitForeign mbSpan pattern safety cconv arg_tys res_ty =
  226. gsGroup . ggsForeignRefs %= (ForeignRef spanTxt pattern safety cconv arg_tys res_ty :)
  227. where
  228. spanTxt = case mbSpan of
  229. Just sp -> T.pack $
  230. unpackFS (srcSpanFile sp) ++
  231. " " ++
  232. show (srcSpanStartLine sp, srcSpanStartCol sp) ++
  233. "-" ++
  234. show (srcSpanEndLine sp, srcSpanEndCol sp)
  235. Nothing -> "<unknown>"
  236. adjPushStack :: Int -> G ()
  237. adjPushStack n = do
  238. stackDepth += n
  239. dropSlots n
  240. dropSlots :: Int -> G ()
  241. dropSlots n = gsGroup . ggsStack %= drop n
  242. -- | add knowledge about the stack slots
  243. addSlots :: [StackSlot] -> G ()
  244. addSlots xs = gsGroup . ggsStack %= (xs++)
  245. stackDepth :: Lens' GenState Int
  246. stackDepth = gsGroup . ggsStackDepth
  247. ----------------------------------------------------------
  248. -- | run the action with no stack info
  249. resetSlots :: G a -> G a
  250. resetSlots m = do
  251. s <- getSlots
  252. d <- use stackDepth
  253. setSlots []
  254. a <- m
  255. setSlots s
  256. stackDepth .= d
  257. return a
  258. -- | run the action with current stack info, but don't let modifications propagate
  259. isolateSlots :: G a -> G a
  260. isolateSlots m = do
  261. s <- getSlots
  262. d <- use stackDepth
  263. a <- m
  264. setSlots s
  265. stackDepth .= d
  266. return a
  267. -- | overwrite our stack knowledge
  268. setSlots :: [StackSlot] -> G ()
  269. setSlots xs = gsGroup . ggsStack .= xs
  270. -- | retrieve our current stack knowledge
  271. getSlots :: G [StackSlot]
  272. getSlots = use (gsGroup . ggsStack)
  273. -- | add `n` unknown slots to our stack knowledge
  274. addUnknownSlots :: Int -> G ()
  275. addUnknownSlots n = addSlots (replicate n SlotUnknown)
  276. throwSimpleSrcErr :: DynFlags -> SrcSpan -> String -> G a
  277. throwSimpleSrcErr df span msg = return $! Ex.throw (simpleSrcErr df span msg)
  278. initState :: DynFlags -> Module -> UniqFM StgExpr -> GenState
  279. initState df m unfloat =
  280. GenState (dfCgSettings df) m df 1 emptyIdCache unfloat def []
  281. runGen :: DynFlags -> Module -> UniqFM StgExpr -> G a -> a
  282. runGen df m unfloat = flip evalState (initState df m unfloat)
  283. instance Semigroup C where
  284. (<>) = liftM2 (<>)
  285. instance Monoid C where
  286. mempty = return mempty
  287. data Special = Stack
  288. | Sp
  289. deriving (Show, Eq)
  290. instance ToJExpr Special where
  291. toJExpr Stack = [je| h$stack |]
  292. toJExpr Sp = [je| h$sp |]
  293. adjSp' :: Int -> JStat
  294. adjSp' 0 = mempty
  295. adjSp' e = [j| `Sp` = `Sp` + `e`; |]
  296. adjSpN' :: Int -> JStat
  297. adjSpN' 0 = mempty
  298. adjSpN' e = [j| `Sp` = `Sp` - `e`; |]
  299. adjSp :: Int -> C
  300. adjSp 0 = return mempty
  301. adjSp e = stackDepth += e >> return [j| `Sp` = `Sp` + `e`; |]
  302. adjSpN :: Int -> C
  303. adjSpN 0 = return mempty
  304. adjSpN e = stackDepth -= e >> return [j| `Sp` = `Sp` - `e`; |]
  305. pushN :: Array Int Ident
  306. pushN = listArray (1,32) $ map (TxtI . T.pack . ("h$p"++) . show) [(1::Int)..32]
  307. pushN' :: Array Int JExpr
  308. pushN' = fmap (ValExpr . JVar) pushN
  309. pushNN :: Array Integer Ident
  310. pushNN = listArray (1,255) $ map (TxtI . T.pack . ("h$pp"++) . show) [(1::Int)..255]
  311. pushNN' :: Array Integer JExpr
  312. pushNN' = fmap (ValExpr . JVar) pushNN
  313. pushOptimized' :: [(Id,Int)]
  314. -> C
  315. pushOptimized' xs = do
  316. slots <- getSlots
  317. pushOptimized =<< (sequence $ zipWith f xs (slots++repeat SlotUnknown))
  318. where
  319. f (i1,n1) (SlotId i2 n2) = (,i1==i2&&n1==n2) <$> genIdsN i1 n1
  320. f (i1,n1) _ = (,False) <$> genIdsN i1 n1
  321. {- | optimized push that reuses existing values on stack
  322. automatically chooses an optimized partial push (h$ppN)
  323. function when possible.
  324. -}
  325. pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there
  326. -> C
  327. pushOptimized [] = return mempty
  328. pushOptimized xs = do
  329. dropSlots l
  330. stackDepth += length xs
  331. go . csInlinePush <$> use gsSettings
  332. where
  333. go True = inlinePush
  334. go _
  335. | all snd xs = adjSp' l
  336. | all (not.snd) xs && l <= 32 =
  337. ApplStat (pushN' ! l) (map fst xs)
  338. | l <= 8 && not (snd $ last xs) =
  339. ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ]
  340. | otherwise = inlinePush
  341. l = length xs
  342. sig :: Integer
  343. sig = L.foldl1' (.|.) $ zipWith (\(_e,b) i -> if not b then bit i else 0) xs [0..]
  344. inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs)
  345. pushSlot i (e,False) = [j| `Stack`[`offset i`] = `e` |]
  346. pushSlot _ _ = mempty
  347. offset i | i == l = [je| `Sp` |]
  348. | otherwise = [je| `Sp` - `l-i` |]
  349. push :: [JExpr] -> C
  350. push xs = do
  351. dropSlots (length xs)
  352. stackDepth += length xs
  353. flip push' xs <$> use gsSettings
  354. push' :: CgSettings -> [JExpr] -> JStat
  355. push' _ [] = mempty
  356. push' cs xs
  357. | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items
  358. | otherwise = ApplStat (toJExpr $ pushN ! l) xs
  359. where
  360. items = zipWith (\i e -> [j| `Stack`[`offset i`] = `e`; |]) [(1::Int)..] xs
  361. offset i | i == l = [je| `Sp` |]
  362. | otherwise = [je| `Sp` - `l-i` |]
  363. l = length xs
  364. popUnknown :: [JExpr] -> C
  365. popUnknown xs = popSkipUnknown 0 xs
  366. popSkipUnknown :: Int -> [JExpr] -> C
  367. popSkipUnknown n xs = popSkip n (map (,SlotUnknown) xs)
  368. pop :: [(JExpr,StackSlot)] -> C
  369. pop = popSkip 0
  370. -- | pop the expressions, but ignore the top n elements of the stack
  371. popSkip :: Int -> [(JExpr,StackSlot)] -> C
  372. popSkip 0 [] = mempty
  373. popSkip n [] = addUnknownSlots n >> adjSpN n
  374. popSkip n xs = do
  375. addUnknownSlots n
  376. addSlots (map snd xs)
  377. a <- adjSpN (length xs + n)
  378. return (loadSkip n (map fst xs) <> a)
  379. -- | pop things, don't upstate stack knowledge
  380. popSkip' :: Int -- ^ number of slots to skip
  381. -> [JExpr] -- ^ assign stack slot values to these
  382. -> JStat
  383. popSkip' 0 [] = mempty
  384. popSkip' n [] = adjSpN' n
  385. popSkip' n tgt = loadSkip n tgt <> adjSpN' (length tgt + n)
  386. -- | like popSkip, but without modifying the stack pointer
  387. loadSkip :: Int -> [JExpr] -> JStat
  388. loadSkip = loadSkipFrom (toJExpr Sp)
  389. loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
  390. loadSkipFrom fr n xs = mconcat items
  391. where
  392. items = reverse $ zipWith (\i e -> [j| `e` = `Stack`[`offset (i+n)`]; |]) [(0::Int)..] (reverse xs)
  393. offset 0 = [je| `fr` |]
  394. offset n = [je| `fr` - `n` |]
  395. -- declare and pop
  396. popSkipI :: Int -> [(Ident,StackSlot)] -> C
  397. popSkipI 0 [] = mempty
  398. popSkipI n [] = adjSpN n
  399. popSkipI n xs = do
  400. addUnknownSlots n
  401. addSlots (map snd xs)
  402. a <- adjSpN (length xs + n)
  403. return (loadSkipI n (map fst xs) <> a)
  404. -- like popSkip, but without modifying sp
  405. loadSkipI :: Int -> [Ident] -> JStat
  406. loadSkipI = loadSkipIFrom (toJExpr Sp)
  407. loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
  408. loadSkipIFrom fr n xs = mconcat items
  409. where
  410. items = reverse $ zipWith f [(0::Int)..] (reverse xs)
  411. offset 0 = fr
  412. offset n = [je| `fr` - `n` |]
  413. f i e = [j| `decl e`;
  414. `e` = `Stack`[`offset (i+n)`];
  415. |]
  416. popn :: Int -> C
  417. popn n = addUnknownSlots n >> adjSpN n
  418. -- below: c argument is closure entry, p argument is (heap) pointer to entry
  419. closureType :: JExpr -> JExpr
  420. closureType c = [je| `c`.f.t |]
  421. isThunk :: JExpr -> JExpr
  422. isThunk c = [je| `c`.f.t === `Thunk` |]
  423. isThunk' :: JExpr -> JExpr
  424. isThunk' f = [je| `f`.t === `Thunk` |]
  425. isBlackhole :: JExpr -> JExpr
  426. isBlackhole c = [je| `c`.f.t === `Blackhole` |]
  427. isFun :: JExpr -> JExpr
  428. isFun c = [je| `c`.f.t === `Fun` |]
  429. isFun' :: JExpr -> JExpr
  430. isFun' f = [je| `f`.t === `Fun` |]
  431. isPap :: JExpr -> JExpr
  432. isPap c = [je| `c`.f.t === `Pap` |]
  433. isPap' :: JExpr -> JExpr
  434. isPap' f = [je| `f`.t === `Pap` |]
  435. isCon :: JExpr -> JExpr
  436. isCon c = [je| `c`.f.t === `Con` |]
  437. isCon' :: JExpr -> JExpr
  438. isCon' f = [je| `f`.t === `Con` |]
  439. conTag :: JExpr -> JExpr
  440. conTag c = [je| `c`.f.a |]
  441. conTag' :: JExpr -> JExpr
  442. conTag' f = [je| `f`.a |]
  443. entry :: JExpr -> JExpr
  444. entry p = [je| `p`.f |]
  445. -- number of arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
  446. funArity :: JExpr -> JExpr
  447. funArity c = [je| `c`.f.a |]
  448. -- function arity with raw reference to the entry
  449. funArity' :: JExpr -> JExpr
  450. funArity' f = [je| `f`.a |]
  451. -- arity of a partial application
  452. papArity :: JExpr -> JExpr
  453. papArity cp = [je| `cp`.d2.d1 |]
  454. funOrPapArity :: JExpr -- ^ heap object
  455. -> Maybe JExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice)
  456. -> JExpr -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments)
  457. funOrPapArity c Nothing =
  458. [je| `isFun c` ? `funArity c` : `papArity c` |]
  459. funOrPapArity c (Just f) =
  460. [je| `isFun' f` ? `funArity' f` : `papArity c` |]
  461. {-
  462. Most stack frames have a static size, stored in f.size, but there
  463. are two exceptions:
  464. - dynamically sized stack frames (f.size === -1) have the size
  465. stored in the stack slot below the header
  466. - h$ap_gen is special
  467. -}
  468. stackFrameSize :: JExpr -- ^ assign frame size to this
  469. -> JExpr -- ^ stack frame header function
  470. -> JStat -- ^ size of the frame, including header
  471. stackFrameSize tgt f =
  472. [j| if(`f` === h$ap_gen) { // h$ap_gen is special
  473. `tgt` = (`Stack`[`Sp`-1] >> 8) + 2;
  474. } else {
  475. var tag = `f`.size;
  476. if(tag < 0) { // dynamic size
  477. `tgt` = `Stack`[`Sp`-1];
  478. } else {
  479. `tgt` = (tag & 0xff) + 1;
  480. }
  481. }
  482. |]
  483. -- some utilities do do something with a range of regs
  484. -- start or end possibly supplied as javascript expr
  485. withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
  486. withRegs start end f = mconcat $ map f [start..end]
  487. withRegs' :: Int -> Int -> (StgReg -> JStat) -> JStat
  488. withRegs' start end f = withRegs (numReg start) (numReg end) f
  489. -- start from js expr, start is guaranteed to be at least min
  490. -- from low to high (fallthrough!)
  491. withRegsS :: JExpr -> StgReg -> Int -> Bool -> (StgReg -> JStat) -> JStat
  492. withRegsS start min end fallthrough f =
  493. SwitchStat start (map mkCase [regNum min..end]) mempty
  494. where
  495. brk | fallthrough = mempty
  496. | otherwise = [j| break; |]
  497. mkCase n = (toJExpr n, [j| `f (numReg n)`; `brk`; |])
  498. -- end from js expr, from high to low
  499. withRegsRE :: Int -> JExpr -> StgReg -> Bool -> (StgReg -> JStat) -> JStat
  500. withRegsRE start end max fallthrough f =
  501. SwitchStat end (reverse $ map mkCase [numReg start..max]) mempty
  502. where
  503. brk | fallthrough = mempty
  504. | otherwise = [j| break; |]
  505. mkCase n = (toJExpr (regNum n), [j| `f n`; `brk` |])
  506. -- | the global linkable unit of a module exports this symbol, depend on it to include that unit
  507. -- (used for cost centres)
  508. moduleGlobalSymbol :: DynFlags -> Module -> Text
  509. moduleGlobalSymbol dflags m
  510. = "h$" <>
  511. T.pack (zEncodeString $ showModule dflags m) <>
  512. "_<global>"
  513. jsIdIdent :: Id -> Maybe Int -> IdType -> G Ident
  514. jsIdIdent i mi suffix = do
  515. IdCache cache <- use gsIdents
  516. case M.lookup key cache of
  517. Just ident -> updateGlobalIdCache ident
  518. Nothing -> do
  519. ident <- jsIdIdent' i mi suffix
  520. let cache' = key `seq` ident `seq` IdCache (M.insert key ident cache)
  521. gsIdents .= cache'
  522. cache' `seq` updateGlobalIdCache ident
  523. where
  524. key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) suffix
  525. updateGlobalIdCache :: Ident -> G Ident
  526. updateGlobalIdCache ji
  527. -- fixme also allow cashing entries for lifting?
  528. | not (isGlobalId i) || isJust mi || suffix /= IdPlain = pure ji
  529. | otherwise = do
  530. GlobalIdCache gidc <- use globalIdCache
  531. case M.lookup ji gidc of
  532. Nothing -> do
  533. globalIdCache .= GlobalIdCache (M.insert ji (key, i) gidc)
  534. return ji
  535. Just _ -> pure ji
  536. globalIdCache :: Lens' GenState GlobalIdCache
  537. globalIdCache = gsGroup . ggsGlobalIdCache
  538. -- uncached
  539. jsIdIdent' :: Id -> Maybe Int -> IdType -> G Ident
  540. jsIdIdent' i mn suffix0 = do
  541. dflags <- use gsDynFlags
  542. (prefix, u) <- mkPrefixU dflags
  543. i' <- (\x -> T.pack $ "h$"++prefix++x++mns++suffix++u) . zEncodeString <$> name
  544. i' `seq` return (TxtI i')
  545. where
  546. suffix = idTypeSuffix suffix0
  547. mns = maybe "" (('_':).show) mn
  548. name = fmap ('.':) . showPpr' . localiseName . getName $ i
  549. mkPrefixU :: DynFlags -> G (String, String)
  550. mkPrefixU dflags
  551. | isExportedId i, Just x <- (nameModule_maybe . getName) i = do
  552. let xstr = showModule dflags x
  553. return (zEncodeString xstr, "")
  554. | otherwise = (,('_':) . encodeUnique . getKey . getUnique $ i) . ('$':)
  555. . zEncodeString . showModule dflags <$> use gsModule
  556. showModule :: DynFlags -> Module -> String
  557. showModule dflags m = pkg ++ ":" ++ modName
  558. where
  559. modName = moduleNameString (moduleName m)
  560. pkg = encodeInstalledUnitId dflags (toInstalledUnitId $ moduleUnitId m)
  561. encodeInstalledUnitId :: DynFlags -> InstalledUnitId -> String
  562. encodeInstalledUnitId dflags k
  563. | isGhcjsPrimPackage dflags k = "ghcjs-prim"
  564. | isGhcjsThPackage dflags k = "ghcjs-th"
  565. | otherwise = installedUnitIdString k
  566. {-
  567. some packages are wired into GHCJS, but not GHC
  568. make sure we don't version them in the output
  569. since the RTS uses thins from them
  570. -}
  571. isGhcjsPrimPackage :: DynFlags -> InstalledUnitId -> Bool
  572. isGhcjsPrimPackage dflags pkgKey
  573. = pn == "ghcjs-prim" ||
  574. (null pn && pkgKey == thisInstalledUnitId dflags &&
  575. any (=="-DBOOTING_PACKAGE=ghcjs-prim") (opt_P dflags))
  576. where
  577. pn = getInstalledPackageName dflags pkgKey
  578. isGhcjsThPackage :: DynFlags -> InstalledUnitId -> Bool
  579. isGhcjsThPackage dflags pkgKey
  580. = pn == "ghcjs-th" ||
  581. (null pn && pkgKey == thisInstalledUnitId dflags &&
  582. any (=="-DBOOTING_PACKAGE=ghcjs-th") (opt_P dflags))
  583. where
  584. pn = getInstalledPackageName dflags pkgKey
  585. ghcjsPrimPackage :: DynFlags -> InstalledUnitId
  586. ghcjsPrimPackage dflags =
  587. case prims of
  588. ((_,k):_) -> toInstalledUnitId k
  589. _ -> error "Package `ghcjs-prim' is required to link executables"
  590. where
  591. prims = filter ((=="ghcjs-prim").fst)
  592. (searchModule dflags (mkModuleName "GHCJS.Prim"))
  593. ghcjsThPackage :: DynFlags -> InstalledUnitId
  594. ghcjsThPackage dflags =
  595. case prims of
  596. ((_,k):_) -> toInstalledUnitId k
  597. _ -> error "Package `ghcjs-th' is required to link executables"
  598. where
  599. prims = filter ((=="ghcjs-th").fst)
  600. (searchModule dflags (mkModuleName "GHCJS.Prim.TH.Eval"))
  601. idTypeSuffix :: IdType -> String
  602. idTypeSuffix IdPlain = ""
  603. idTypeSuffix IdEntry = "_e"
  604. idTypeSuffix IdConEntry = "_con_e"
  605. jsVar :: String -> JExpr
  606. jsVar v = ValExpr . JVar . TxtI . T.pack $ v
  607. jsId :: Id -> G JExpr
  608. jsId i
  609. -- | i == trueDataConId = return $ toJExpr True
  610. -- | i == falseDataConId = return $ toJExpr False
  611. | otherwise = ValExpr . JVar <$> jsIdIdent i Nothing IdPlain
  612. -- entry id
  613. jsEnId :: Id -> G JExpr
  614. jsEnId i = ValExpr . JVar <$> jsEnIdI i
  615. jsEnIdI :: Id -> G Ident
  616. jsEnIdI i = jsIdIdent i Nothing IdEntry
  617. jsEntryId :: Id -> G JExpr
  618. jsEntryId i = ValExpr . JVar <$> jsEntryIdI i
  619. jsEntryIdI :: Id -> G Ident
  620. jsEntryIdI i = jsIdIdent i Nothing IdEntry
  621. -- datacon entry, different name than the wrapper
  622. jsDcEntryId :: Id -> G JExpr
  623. jsDcEntryId i = ValExpr . JVar <$> jsDcEntryIdI i
  624. jsDcEntryIdI :: Id -> G Ident
  625. jsDcEntryIdI i = jsIdIdent i Nothing IdConEntry
  626. jsIdV :: Id -> G JVal
  627. jsIdV i = JVar <$> jsIdIdent i Nothing IdPlain
  628. jsIdI :: Id -> G Ident
  629. jsIdI i = jsIdIdent i Nothing IdPlain
  630. -- some types, Word64, Addr#, unboxed tuple have more than one javascript var
  631. jsIdIN :: Id -> Int -> G Ident
  632. jsIdIN i n = jsIdIdent i (Just n) IdPlain
  633. jsIdN :: Id -> Int -> G JExpr
  634. jsIdN i n = ValExpr . JVar <$> jsIdIdent i (Just n) IdPlain
  635. -- | generate all js vars for the ids (can be multiple per var)
  636. genIds :: Id -> G [JExpr]
  637. genIds i
  638. | s == 0 = return mempty
  639. | s == 1 = (:[]) <$> jsId i
  640. | otherwise = mapM (jsIdN i) [1..s]
  641. where
  642. s = typeSize (idType i)
  643. genIdsN :: Id -> Int -> G JExpr
  644. genIdsN i n = do
  645. xs <- genIds i
  646. return $ xs !! (n-1)
  647. -- | get all idents for an id
  648. genIdsI :: Id -> G [Ident]
  649. genIdsI i
  650. | s == 1 = (:[]) <$> jsIdI i
  651. | otherwise = mapM (jsIdIN i) [1..s]
  652. where
  653. s = typeSize (idType i)
  654. genIdsIN :: Id -> Int -> G Ident
  655. genIdsIN i n = do
  656. xs <- genIdsI i
  657. return $ xs !! (n-1)
  658. -- | declare all js vars for the id
  659. declIds :: Id -> C
  660. declIds i
  661. | s == 0 = return mempty
  662. | s == 1 = decl <$> jsIdI i
  663. | otherwise = mconcat <$> mapM (\n -> decl <$> jsIdIN i n) [1..s]
  664. where
  665. s = typeSize (idType i)