Skip to content

Commit 5d88d26

Browse files
tbagrel1tbagrel1
committed
separate file for autogenerated instances for gfill, and prevent gfill to be used on ctors with unpacked fields
1 parent 93dd776 commit 5d88d26

File tree

7 files changed

+450
-120
lines changed

7 files changed

+450
-120
lines changed

‎examples-version-changes/ghc-dps-compact/after/Compact/SExpr.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@
1717

1818
module Compact.SExpr where
1919

20-
import Compact.Destination.Internal
20+
import Compact.Destination
2121
import Control.DeepSeq (NFData)
2222
import Control.Functor.Linear ((<&>))
2323
import Data.ByteString.Char8 (ByteString)

‎linear-base.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,8 @@ library
4848
exposed-modules:
4949
Compact.Destination
5050
Compact.Destination.Internal
51+
Compact.Destination.GFill
52+
Compact.Destination.Fill
5153
Control.Monad.IO.Class.Linear
5254
Control.Functor.Linear
5355
Control.Functor.Linear.Internal.Class

‎src-version-changes/ghc-dps-compact/after/Compact/Destination.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -17,3 +17,4 @@ module Compact.Destination
1717
where
1818

1919
import Compact.Destination.Internal
20+
import Compact.Destination.Fill

‎src-version-changes/ghc-dps-compact/after/Compact/Destination/Fill.hs‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
{-# LANGUAGE GHC2021 #-}
2+
{-# LANGUAGE AllowAmbiguousTypes #-}
3+
{-# LANGUAGE DataKinds #-}
4+
{-# LANGUAGE DerivingVia #-}
5+
{-# LANGUAGE GADTs #-}
6+
{-# LANGUAGE ImpredicativeTypes #-}
7+
{-# LANGUAGE LinearTypes #-}
8+
{-# LANGUAGE MagicHash #-}
9+
{-# LANGUAGE PatternSynonyms #-}
10+
{-# LANGUAGE RecordWildCards #-}
11+
{-# LANGUAGE ScopedTypeVariables #-}
12+
{-# LANGUAGE TypeFamilies #-}
13+
{-# LANGUAGE UnboxedTuples #-}
14+
{-# LANGUAGE UndecidableInstances #-}
15+
{-# OPTIONS_GHC -Wno-name-shadowing #-}
16+
{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-}
17+
{-# OPTIONS_HADDOCK hide #-}
18+
19+
module Compact.Destination.Fill where
20+
21+
import Compact.Destination.Internal
22+
import Compact.Destination.GFill
23+
import Data.Kind (Type)
24+
import GHC.Compact (Compact (..))
25+
import GHC.MVar (MVar (..))
26+
import GHC.Exts
27+
import Unsafe.Linear (toLinear)
28+
29+
class Fill lCtor (a :: Type) where
30+
_fill :: forall (r :: Type). (Region r) => Dest r a -> DestsOf lCtor r a
31+
32+
instance (specCtor ~ LiftedCtorToSpecCtor lCtor a, GFill# lCtor specCtor a) => Fill lCtor a where
33+
_fill :: forall (r :: Type). (Region r) => Dest r a -> DestsOf lCtor r a
34+
_fill (Dest d#) = case getRegionInfo @r of
35+
(RegionInfo (Compact c# _ (MVar m#))) -> case runRW# (gFill# @lCtor @specCtor @a @r c# m# d#) of (# _, res #) -> res
36+
{-# INLINE _fill #-}
37+
38+
fill :: forall lCtor (r :: Type) (a :: Type). (Fill lCtor a, Region r) => Dest r a %1 -> DestsOf lCtor r a
39+
fill = toLinear (_fill @lCtor @a @r)
40+
{-# INLINE fill #-}

‎src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs‎

Lines changed: 296 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,296 @@
1+
2+
{-# LANGUAGE GHC2021 #-}
3+
{-# LANGUAGE AllowAmbiguousTypes #-}
4+
{-# LANGUAGE DataKinds #-}
5+
{-# LANGUAGE DerivingVia #-}
6+
{-# LANGUAGE GADTs #-}
7+
{-# LANGUAGE ImpredicativeTypes #-}
8+
{-# LANGUAGE LinearTypes #-}
9+
{-# LANGUAGE MagicHash #-}
10+
{-# LANGUAGE PatternSynonyms #-}
11+
{-# LANGUAGE RecordWildCards #-}
12+
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE TypeFamilies #-}
14+
{-# LANGUAGE UnboxedTuples #-}
15+
{-# LANGUAGE UndecidableInstances #-}
16+
{-# OPTIONS_GHC -Wno-name-shadowing #-}
17+
{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-}
18+
{-# OPTIONS_HADDOCK hide #-}
19+
20+
module Compact.Destination.GFill where
21+
22+
-- *****************************************************************************
23+
-- * THIS FILE IS GENERATED BY SCRIPT GFill.hs.py, PLEASE DO NOT EDIT MANUALLY *
24+
-- *****************************************************************************
25+
26+
import Compact.Destination.Internal
27+
import GHC.Generics
28+
import Data.Kind (Type)
29+
import GHC.Exts
30+
import GHC.TypeLits
31+
import Unsafe.Coerce (unsafeCoerceAddr)
32+
33+
class GFill# lCtor (specCtor :: (Meta, [(Meta, Type)])) (a :: Type) where
34+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf specCtor r #)
35+
36+
instance (
37+
Generic a,
38+
repA ~ Rep a (),
39+
metaA ~ GDatatypeMetaOf repA,
40+
Datatype metaA,
41+
'MetaCons symCtor fix hasSel ~ metaCtor,
42+
Constructor metaCtor,
43+
LiftedCtorToSymbol lCtor ~ symCtor,
44+
'Just '(metaCtor, '[ ]) ~ GSpecCtorOf symCtor (Rep a ())
45+
) => GFill# lCtor '(metaCtor, '[ ]) a where
46+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
47+
-> (# State# RealWorld, () #)
48+
gFill# c# m# d# s0 =
49+
case takeMVar# m# s0 of
50+
(# s1, () #) ->
51+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
52+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
53+
(# s3, pXInRegion# #) -> case getSlots0# xInRegion bH# bW# s3 of
54+
(# s4, (# #) #) -> case putMVar# m# () s4 of
55+
s5 -> putDebugLn#
56+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [])
57+
(# s5, () #)
58+
{-# INLINE gFill# #-}
59+
60+
instance (
61+
Generic a,
62+
repA ~ Rep a (),
63+
metaA ~ GDatatypeMetaOf repA,
64+
Datatype metaA,
65+
'MetaCons symCtor fix hasSel ~ metaCtor,
66+
Constructor metaCtor,
67+
LiftedCtorToSymbol lCtor ~ symCtor,
68+
'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0)]) ~ GSpecCtorOf symCtor (Rep a ()),
69+
NotUnpacked ds0
70+
) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0)]) a where
71+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
72+
-> (# State# RealWorld, (Dest r t0) #)
73+
gFill# c# m# d# s0 =
74+
case takeMVar# m# s0 of
75+
(# s1, () #) ->
76+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
77+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
78+
(# s3, pXInRegion# #) -> case getSlots1# xInRegion bH# bW# s3 of
79+
(# s4, (# d0# #) #) -> case putMVar# m# () s4 of
80+
s5 -> putDebugLn#
81+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#])
82+
(# s5, (Dest d0#) #)
83+
{-# INLINE gFill# #-}
84+
85+
instance (
86+
Generic a,
87+
repA ~ Rep a (),
88+
metaA ~ GDatatypeMetaOf repA,
89+
Datatype metaA,
90+
'MetaCons symCtor fix hasSel ~ metaCtor,
91+
Constructor metaCtor,
92+
LiftedCtorToSymbol lCtor ~ symCtor,
93+
'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
94+
'( 'MetaSel f1 u1 ss1 ds1, t1)]) ~ GSpecCtorOf symCtor (Rep a ()),
95+
NotUnpacked ds0,
96+
NotUnpacked ds1
97+
) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
98+
'( 'MetaSel f1 u1 ss1 ds1, t1)]) a where
99+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
100+
-> (# State# RealWorld, (Dest r t0, Dest r t1) #)
101+
gFill# c# m# d# s0 =
102+
case takeMVar# m# s0 of
103+
(# s1, () #) ->
104+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
105+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
106+
(# s3, pXInRegion# #) -> case getSlots2# xInRegion bH# bW# s3 of
107+
(# s4, (# d0#, d1# #) #) -> case putMVar# m# () s4 of
108+
s5 -> putDebugLn#
109+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#])
110+
(# s5, (Dest d0#, Dest d1#) #)
111+
{-# INLINE gFill# #-}
112+
113+
instance (
114+
Generic a,
115+
repA ~ Rep a (),
116+
metaA ~ GDatatypeMetaOf repA,
117+
Datatype metaA,
118+
'MetaCons symCtor fix hasSel ~ metaCtor,
119+
Constructor metaCtor,
120+
LiftedCtorToSymbol lCtor ~ symCtor,
121+
'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
122+
'( 'MetaSel f1 u1 ss1 ds1, t1),
123+
'( 'MetaSel f2 u2 ss2 ds2, t2)]) ~ GSpecCtorOf symCtor (Rep a ()),
124+
NotUnpacked ds0,
125+
NotUnpacked ds1,
126+
NotUnpacked ds2
127+
) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
128+
'( 'MetaSel f1 u1 ss1 ds1, t1),
129+
'( 'MetaSel f2 u2 ss2 ds2, t2)]) a where
130+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
131+
-> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2) #)
132+
gFill# c# m# d# s0 =
133+
case takeMVar# m# s0 of
134+
(# s1, () #) ->
135+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
136+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
137+
(# s3, pXInRegion# #) -> case getSlots3# xInRegion bH# bW# s3 of
138+
(# s4, (# d0#, d1#, d2# #) #) -> case putMVar# m# () s4 of
139+
s5 -> putDebugLn#
140+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#])
141+
(# s5, (Dest d0#, Dest d1#, Dest d2#) #)
142+
{-# INLINE gFill# #-}
143+
144+
instance (
145+
Generic a,
146+
repA ~ Rep a (),
147+
metaA ~ GDatatypeMetaOf repA,
148+
Datatype metaA,
149+
'MetaCons symCtor fix hasSel ~ metaCtor,
150+
Constructor metaCtor,
151+
LiftedCtorToSymbol lCtor ~ symCtor,
152+
'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
153+
'( 'MetaSel f1 u1 ss1 ds1, t1),
154+
'( 'MetaSel f2 u2 ss2 ds2, t2),
155+
'( 'MetaSel f3 u3 ss3 ds3, t3)]) ~ GSpecCtorOf symCtor (Rep a ()),
156+
NotUnpacked ds0,
157+
NotUnpacked ds1,
158+
NotUnpacked ds2,
159+
NotUnpacked ds3
160+
) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
161+
'( 'MetaSel f1 u1 ss1 ds1, t1),
162+
'( 'MetaSel f2 u2 ss2 ds2, t2),
163+
'( 'MetaSel f3 u3 ss3 ds3, t3)]) a where
164+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
165+
-> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3) #)
166+
gFill# c# m# d# s0 =
167+
case takeMVar# m# s0 of
168+
(# s1, () #) ->
169+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
170+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
171+
(# s3, pXInRegion# #) -> case getSlots4# xInRegion bH# bW# s3 of
172+
(# s4, (# d0#, d1#, d2#, d3# #) #) -> case putMVar# m# () s4 of
173+
s5 -> putDebugLn#
174+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#])
175+
(# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#) #)
176+
{-# INLINE gFill# #-}
177+
178+
instance (
179+
Generic a,
180+
repA ~ Rep a (),
181+
metaA ~ GDatatypeMetaOf repA,
182+
Datatype metaA,
183+
'MetaCons symCtor fix hasSel ~ metaCtor,
184+
Constructor metaCtor,
185+
LiftedCtorToSymbol lCtor ~ symCtor,
186+
'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
187+
'( 'MetaSel f1 u1 ss1 ds1, t1),
188+
'( 'MetaSel f2 u2 ss2 ds2, t2),
189+
'( 'MetaSel f3 u3 ss3 ds3, t3),
190+
'( 'MetaSel f4 u4 ss4 ds4, t4)]) ~ GSpecCtorOf symCtor (Rep a ()),
191+
NotUnpacked ds0,
192+
NotUnpacked ds1,
193+
NotUnpacked ds2,
194+
NotUnpacked ds3,
195+
NotUnpacked ds4
196+
) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
197+
'( 'MetaSel f1 u1 ss1 ds1, t1),
198+
'( 'MetaSel f2 u2 ss2 ds2, t2),
199+
'( 'MetaSel f3 u3 ss3 ds3, t3),
200+
'( 'MetaSel f4 u4 ss4 ds4, t4)]) a where
201+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
202+
-> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3, Dest r t4) #)
203+
gFill# c# m# d# s0 =
204+
case takeMVar# m# s0 of
205+
(# s1, () #) ->
206+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
207+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
208+
(# s3, pXInRegion# #) -> case getSlots5# xInRegion bH# bW# s3 of
209+
(# s4, (# d0#, d1#, d2#, d3#, d4# #) #) -> case putMVar# m# () s4 of
210+
s5 -> putDebugLn#
211+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#])
212+
(# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#, Dest d4#) #)
213+
{-# INLINE gFill# #-}
214+
215+
instance (
216+
Generic a,
217+
repA ~ Rep a (),
218+
metaA ~ GDatatypeMetaOf repA,
219+
Datatype metaA,
220+
'MetaCons symCtor fix hasSel ~ metaCtor,
221+
Constructor metaCtor,
222+
LiftedCtorToSymbol lCtor ~ symCtor,
223+
'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
224+
'( 'MetaSel f1 u1 ss1 ds1, t1),
225+
'( 'MetaSel f2 u2 ss2 ds2, t2),
226+
'( 'MetaSel f3 u3 ss3 ds3, t3),
227+
'( 'MetaSel f4 u4 ss4 ds4, t4),
228+
'( 'MetaSel f5 u5 ss5 ds5, t5)]) ~ GSpecCtorOf symCtor (Rep a ()),
229+
NotUnpacked ds0,
230+
NotUnpacked ds1,
231+
NotUnpacked ds2,
232+
NotUnpacked ds3,
233+
NotUnpacked ds4,
234+
NotUnpacked ds5
235+
) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
236+
'( 'MetaSel f1 u1 ss1 ds1, t1),
237+
'( 'MetaSel f2 u2 ss2 ds2, t2),
238+
'( 'MetaSel f3 u3 ss3 ds3, t3),
239+
'( 'MetaSel f4 u4 ss4 ds4, t4),
240+
'( 'MetaSel f5 u5 ss5 ds5, t5)]) a where
241+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
242+
-> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3, Dest r t4, Dest r t5) #)
243+
gFill# c# m# d# s0 =
244+
case takeMVar# m# s0 of
245+
(# s1, () #) ->
246+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
247+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
248+
(# s3, pXInRegion# #) -> case getSlots6# xInRegion bH# bW# s3 of
249+
(# s4, (# d0#, d1#, d2#, d3#, d4#, d5# #) #) -> case putMVar# m# () s4 of
250+
s5 -> putDebugLn#
251+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#, Ptr d5#])
252+
(# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#, Dest d4#, Dest d5#) #)
253+
{-# INLINE gFill# #-}
254+
255+
instance (
256+
Generic a,
257+
repA ~ Rep a (),
258+
metaA ~ GDatatypeMetaOf repA,
259+
Datatype metaA,
260+
'MetaCons symCtor fix hasSel ~ metaCtor,
261+
Constructor metaCtor,
262+
LiftedCtorToSymbol lCtor ~ symCtor,
263+
'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
264+
'( 'MetaSel f1 u1 ss1 ds1, t1),
265+
'( 'MetaSel f2 u2 ss2 ds2, t2),
266+
'( 'MetaSel f3 u3 ss3 ds3, t3),
267+
'( 'MetaSel f4 u4 ss4 ds4, t4),
268+
'( 'MetaSel f5 u5 ss5 ds5, t5),
269+
'( 'MetaSel f6 u6 ss6 ds6, t6)]) ~ GSpecCtorOf symCtor (Rep a ()),
270+
NotUnpacked ds0,
271+
NotUnpacked ds1,
272+
NotUnpacked ds2,
273+
NotUnpacked ds3,
274+
NotUnpacked ds4,
275+
NotUnpacked ds5,
276+
NotUnpacked ds6
277+
) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0),
278+
'( 'MetaSel f1 u1 ss1 ds1, t1),
279+
'( 'MetaSel f2 u2 ss2 ds2, t2),
280+
'( 'MetaSel f3 u3 ss3 ds3, t3),
281+
'( 'MetaSel f4 u4 ss4 ds4, t4),
282+
'( 'MetaSel f5 u5 ss5 ds5, t5),
283+
'( 'MetaSel f6 u6 ss6 ds6, t6)]) a where
284+
gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld
285+
-> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3, Dest r t4, Dest r t5, Dest r t6) #)
286+
gFill# c# m# d# s0 =
287+
case takeMVar# m# s0 of
288+
(# s1, () #) ->
289+
case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of
290+
(# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of
291+
(# s3, pXInRegion# #) -> case getSlots7# xInRegion bH# bW# s3 of
292+
(# s4, (# d0#, d1#, d2#, d3#, d4#, d5#, d6# #) #) -> case putMVar# m# () s4 of
293+
s5 -> putDebugLn#
294+
(showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#, Ptr d5#, Ptr d6#])
295+
(# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#, Dest d4#, Dest d5#, Dest d6#) #)
296+
{-# INLINE gFill# #-}

0 commit comments

Comments
 (0)