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
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module : GHC.StgToJS.DataCon
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Jeffrey Young <jeffrey.young@iohk.io>
-- Luite Stegeman <luite.stegeman@iohk.io>
-- Sylvain Henry <sylvain.henry@iohk.io>
-- Josh Meredith <josh.meredith@iohk.io>
-- Stability : experimental
--
-- Code generation of data constructors
-----------------------------------------------------------------------------
module GHC.StgToJS.DataCon
( genCon
, allocCon
, allocUnboxedCon
, allocDynamicE
, allocDynamic
)
where
import GHC.Prelude
import GHC.JS.JStg.Syntax
import GHC.JS.Ident
import GHC.JS.Make
import GHC.JS.Transform
import GHC.StgToJS.Closure
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.Profiling
import GHC.StgToJS.Utils
import GHC.StgToJS.Ids
import GHC.Core.DataCon
import GHC.Types.CostCentre
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Maybe
-- | Generate a data constructor. Special handling for unboxed tuples
genCon :: ExprCtx -> DataCon -> [JStgExpr] -> G JStgStat
genCon ctx con args
| isUnboxedTupleDataCon con
= return $ assignToExprCtx ctx args
| [Var ctxi] <- concatMap (typex_expr) (ctxTarget ctx)
= allocCon ctxi con currentCCS args
| xs <- concatMap typex_expr (ctxTarget ctx)
= pprPanic "genCon: unhandled DataCon" (ppr (con
, map jStgExprToJS args
, map jStgExprToJS xs
))
-- | Allocate a data constructor. Allocate in this context means bind the data
-- constructor to 'to'
allocCon :: Ident -> DataCon -> CostCentreStack -> [JStgExpr] -> G JStgStat
allocCon to con cc xs
| isBoolDataCon con || isUnboxableCon con =
return $ AssignStat (Var to) AssignOp (allocUnboxedCon con xs)
{- | null xs = do
i <- varForId (dataConWorkId con)
return (assignj to i) -}
| otherwise = do
e <- varForDataConWorker con
cs <- getSettings
prof <- profiling
ccsJ <- if prof then ccsVarJ cc else return Nothing
return $ allocDynamic cs False to e xs ccsJ
-- | Allocate an unboxed data constructor. If we have a bool we calculate the
-- right value. If not then we expect a singleton list and unbox by converting
-- ''C x' to 'x'. NB. This function may panic.
allocUnboxedCon :: DataCon -> [JStgExpr] -> JStgExpr
allocUnboxedCon con = \case
[]
| isBoolDataCon con && dataConTag con == 1 -> false_
| isBoolDataCon con && dataConTag con == 2 -> true_
[x]
| isUnboxableCon con -> x
xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con, map jStgExprToJS xs))
-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout.
allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig
-> JStgExpr
-> [JStgExpr]
-> Maybe JStgExpr
-> JStgExpr
allocDynamicE inline_alloc entry free cc
| inline_alloc || length free > jsClosureCount
= newClosure $ mkClosure entry free zero_ cc
| otherwise = ApplExpr allocFun (entry : free ++ maybeToList cc)
where
allocFun = allocClsA (length free)
-- | Allocate a dynamic object
allocDynamic :: StgToJSConfig -> Bool -> Ident -> JStgExpr -> [JStgExpr] -> Maybe JStgExpr -> JStgStat
allocDynamic s need_decl to entry free cc
| need_decl = DeclStat to (Just value)
| otherwise = AssignStat (Var to) AssignOp value
where
value = allocDynamicE (csInlineAlloc s) entry free cc
|
