blob: 675fd6d583d761a5bfd2a69ff3563cb01bb73e9c (
plain)
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.Unsat.Syntax
import GHC.JS.Transform
import GHC.JS.Make
import GHC.StgToJS.Closure
import GHC.StgToJS.ExprCtx
import GHC.StgToJS.Types
import GHC.StgToJS.Monad
import GHC.StgToJS.CoreUtils
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 -> [JExpr] -> G JStat
genCon ctx con args
| isUnboxedTupleDataCon con
= return $ assignToExprCtx ctx args
| [ValExpr (JVar ctxi)] <- concatMap typex_expr (ctxTarget ctx)
= allocCon ctxi con currentCCS args
| xs <- concatMap typex_expr (ctxTarget ctx)
= pprPanic "genCon: unhandled DataCon" (ppr (con
, fmap satJExpr args
, fmap satJExpr xs
))
-- | Allocate a data constructor. Allocate in this context means bind the data
-- constructor to 'to'
allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
allocCon to con cc xs
| isBoolDataCon con || isUnboxableCon con =
return (toJExpr to |= 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 -> [JExpr] -> JExpr
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, fmap satJExpr xs))
-- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout.
allocDynamicE :: Bool -- ^ csInlineAlloc from StgToJSConfig
-> JExpr
-> [JExpr]
-> Maybe JExpr
-> JExpr
allocDynamicE inline_alloc entry free cc
| inline_alloc || length free > jsClosureCount
= newClosure $ mkClosure entry free (ValExpr (JInt 0)) cc
| otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc)
where
allocFun = allocClsA (length free)
-- | Allocate a dynamic object
allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
allocDynamic s need_decl to entry free cc
| need_decl = DeclStat to (Just value)
| otherwise = toJExpr to |= value
where
value = allocDynamicE (csInlineAlloc s) entry free cc
|
