From c7ee58eed0dd32ca9a42f0638c256e10f1c778f1 Mon Sep 17 00:00:00 2001 From: Thomas BAGREL Date: Fri, 8 Nov 2024 17:05:20 +0100 Subject: [PATCH] separate file for autogenerated instances for gfill, and prevent gfill to be used on ctors with unpacked fields --- cabal.project | 1 + .../ghc-dps-compact/after/Compact/SExpr.hs | 2 +- linear-base.cabal | 2 + .../after/Compact/Destination.hs | 1 + .../after/Compact/Destination/Fill.hs | 40 +++ .../after/Compact/Destination/GFill.hs | 296 ++++++++++++++++++ .../after/Compact/Destination/GFill.hs.py | 99 ++++++ .../after/Compact/Destination/Internal.hs | 130 +------- 8 files changed, 451 insertions(+), 120 deletions(-) create mode 100644 src-version-changes/ghc-dps-compact/after/Compact/Destination/Fill.hs create mode 100644 src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs create mode 100644 src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs.py diff --git a/cabal.project b/cabal.project index 615a378f..19fec939 100644 --- a/cabal.project +++ b/cabal.project @@ -3,3 +3,4 @@ tests: True benchmarks: True allow-newer: all index-state: 2024-09-13T13:31:57Z +with-compiler: ./ghc-dps-compact-95615577d7/bin/ghc diff --git a/examples-version-changes/ghc-dps-compact/after/Compact/SExpr.hs b/examples-version-changes/ghc-dps-compact/after/Compact/SExpr.hs index 36fd6dc4..fbc6c171 100644 --- a/examples-version-changes/ghc-dps-compact/after/Compact/SExpr.hs +++ b/examples-version-changes/ghc-dps-compact/after/Compact/SExpr.hs @@ -17,7 +17,7 @@ module Compact.SExpr where -import Compact.Destination.Internal +import Compact.Destination import Control.DeepSeq (NFData) import Control.Functor.Linear ((<&>)) import Data.ByteString.Char8 (ByteString) diff --git a/linear-base.cabal b/linear-base.cabal index 4aef2f24..7c3486f3 100644 --- a/linear-base.cabal +++ b/linear-base.cabal @@ -48,6 +48,8 @@ library exposed-modules: Compact.Destination Compact.Destination.Internal + Compact.Destination.GFill + Compact.Destination.Fill Control.Monad.IO.Class.Linear Control.Functor.Linear Control.Functor.Linear.Internal.Class diff --git a/src-version-changes/ghc-dps-compact/after/Compact/Destination.hs b/src-version-changes/ghc-dps-compact/after/Compact/Destination.hs index d6be5324..1ef328c7 100644 --- a/src-version-changes/ghc-dps-compact/after/Compact/Destination.hs +++ b/src-version-changes/ghc-dps-compact/after/Compact/Destination.hs @@ -17,3 +17,4 @@ module Compact.Destination where import Compact.Destination.Internal +import Compact.Destination.Fill diff --git a/src-version-changes/ghc-dps-compact/after/Compact/Destination/Fill.hs b/src-version-changes/ghc-dps-compact/after/Compact/Destination/Fill.hs new file mode 100644 index 00000000..95b5293f --- /dev/null +++ b/src-version-changes/ghc-dps-compact/after/Compact/Destination/Fill.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +{-# OPTIONS_HADDOCK hide #-} + +module Compact.Destination.Fill where + +import Compact.Destination.Internal +import Compact.Destination.GFill +import Data.Kind (Type) +import GHC.Compact (Compact (..)) +import GHC.MVar (MVar (..)) +import GHC.Exts +import Unsafe.Linear (toLinear) + +class Fill lCtor (a :: Type) where + _fill :: forall (r :: Type). (Region r) => Dest r a -> DestsOf lCtor r a + +instance (specCtor ~ LiftedCtorToSpecCtor lCtor a, GFill# lCtor specCtor a) => Fill lCtor a where + _fill :: forall (r :: Type). (Region r) => Dest r a -> DestsOf lCtor r a + _fill (Dest d#) = case getRegionInfo @r of + (RegionInfo (Compact c# _ (MVar m#))) -> case runRW# (gFill# @lCtor @specCtor @a @r c# m# d#) of (# _, res #) -> res + {-# INLINE _fill #-} + +fill :: forall lCtor (r :: Type) (a :: Type). (Fill lCtor a, Region r) => Dest r a %1 -> DestsOf lCtor r a +fill = toLinear (_fill @lCtor @a @r) +{-# INLINE fill #-} \ No newline at end of file diff --git a/src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs b/src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs new file mode 100644 index 00000000..b066da1c --- /dev/null +++ b/src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs @@ -0,0 +1,296 @@ + +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +{-# OPTIONS_HADDOCK hide #-} + +module Compact.Destination.GFill where + +-- ***************************************************************************** +-- * THIS FILE IS GENERATED BY SCRIPT GFill.hs.py, PLEASE DO NOT EDIT MANUALLY * +-- ***************************************************************************** + +import Compact.Destination.Internal +import GHC.Generics +import Data.Kind (Type) +import GHC.Exts +import GHC.TypeLits +import Unsafe.Coerce (unsafeCoerceAddr) + +class GFill# lCtor (specCtor :: (Meta, [(Meta, Type)])) (a :: Type) where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf specCtor r #) + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ ]) ~ GSpecCtorOf symCtor (Rep a ()) + ) => GFill# lCtor '(metaCtor, '[ ]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, () #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots0# xInRegion bH# bW# s3 of + (# s4, (# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) []) + (# s5, () #) + {-# INLINE gFill# #-} + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0)]) ~ GSpecCtorOf symCtor (Rep a ()), + NotUnpacked ds0 + ) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0)]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, (Dest r t0) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots1# xInRegion bH# bW# s3 of + (# s4, (# d0# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#]) + (# s5, (Dest d0#) #) + {-# INLINE gFill# #-} + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1)]) ~ GSpecCtorOf symCtor (Rep a ()), + NotUnpacked ds0, + NotUnpacked ds1 + ) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1)]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, (Dest r t0, Dest r t1) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots2# xInRegion bH# bW# s3 of + (# s4, (# d0#, d1# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#]) + (# s5, (Dest d0#, Dest d1#) #) + {-# INLINE gFill# #-} + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2)]) ~ GSpecCtorOf symCtor (Rep a ()), + NotUnpacked ds0, + NotUnpacked ds1, + NotUnpacked ds2 + ) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2)]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots3# xInRegion bH# bW# s3 of + (# s4, (# d0#, d1#, d2# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#]) + (# s5, (Dest d0#, Dest d1#, Dest d2#) #) + {-# INLINE gFill# #-} + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3)]) ~ GSpecCtorOf symCtor (Rep a ()), + NotUnpacked ds0, + NotUnpacked ds1, + NotUnpacked ds2, + NotUnpacked ds3 + ) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3)]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots4# xInRegion bH# bW# s3 of + (# s4, (# d0#, d1#, d2#, d3# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#]) + (# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#) #) + {-# INLINE gFill# #-} + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3), + '( 'MetaSel f4 u4 ss4 ds4, t4)]) ~ GSpecCtorOf symCtor (Rep a ()), + NotUnpacked ds0, + NotUnpacked ds1, + NotUnpacked ds2, + NotUnpacked ds3, + NotUnpacked ds4 + ) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3), + '( 'MetaSel f4 u4 ss4 ds4, t4)]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3, Dest r t4) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots5# xInRegion bH# bW# s3 of + (# s4, (# d0#, d1#, d2#, d3#, d4# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#]) + (# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#, Dest d4#) #) + {-# INLINE gFill# #-} + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3), + '( 'MetaSel f4 u4 ss4 ds4, t4), + '( 'MetaSel f5 u5 ss5 ds5, t5)]) ~ GSpecCtorOf symCtor (Rep a ()), + NotUnpacked ds0, + NotUnpacked ds1, + NotUnpacked ds2, + NotUnpacked ds3, + NotUnpacked ds4, + NotUnpacked ds5 + ) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3), + '( 'MetaSel f4 u4 ss4 ds4, t4), + '( 'MetaSel f5 u5 ss5 ds5, t5)]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3, Dest r t4, Dest r t5) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots6# xInRegion bH# bW# s3 of + (# s4, (# d0#, d1#, d2#, d3#, d4#, d5# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#, Ptr d5#]) + (# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#, Dest d4#, Dest d5#) #) + {-# INLINE gFill# #-} + +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3), + '( 'MetaSel f4 u4 ss4 ds4, t4), + '( 'MetaSel f5 u5 ss5 ds5, t5), + '( 'MetaSel f6 u6 ss6 ds6, t6)]) ~ GSpecCtorOf symCtor (Rep a ()), + NotUnpacked ds0, + NotUnpacked ds1, + NotUnpacked ds2, + NotUnpacked ds3, + NotUnpacked ds4, + NotUnpacked ds5, + NotUnpacked ds6 + ) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), + '( 'MetaSel f1 u1 ss1 ds1, t1), + '( 'MetaSel f2 u2 ss2 ds2, t2), + '( 'MetaSel f3 u3 ss3 ds3, t3), + '( 'MetaSel f4 u4 ss4 ds4, t4), + '( 'MetaSel f5 u5 ss5 ds5, t5), + '( 'MetaSel f6 u6 ss6 ds6, t6)]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, (Dest r t0, Dest r t1, Dest r t2, Dest r t3, Dest r t4, Dest r t5, Dest r t6) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots7# xInRegion bH# bW# s3 of + (# s4, (# d0#, d1#, d2#, d3#, d4#, d5#, d6# #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#, Ptr d5#, Ptr d6#]) + (# s5, (Dest d0#, Dest d1#, Dest d2#, Dest d3#, Dest d4#, Dest d5#, Dest d6#) #) + {-# INLINE gFill# #-} diff --git a/src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs.py b/src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs.py new file mode 100644 index 00000000..b56ed4d5 --- /dev/null +++ b/src-version-changes/ghc-dps-compact/after/Compact/Destination/GFill.hs.py @@ -0,0 +1,99 @@ +import os + +HEADER = """ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -dsuppress-all #-} +{-# OPTIONS_HADDOCK hide #-} + +module Compact.Destination.GFill where + +-- ***************************************************************************** +-- * THIS FILE IS GENERATED BY SCRIPT GFill.hs.py, PLEASE DO NOT EDIT MANUALLY * +-- ***************************************************************************** + +import Compact.Destination.Internal +import GHC.Generics +import Data.Kind (Type) +import GHC.Exts +import GHC.TypeLits +import Unsafe.Coerce (unsafeCoerceAddr) + +class GFill# lCtor (specCtor :: (Meta, [(Meta, Type)])) (a :: Type) where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf specCtor r #) +""" + +INSTANCE = """ +instance ( + Generic a, + repA ~ Rep a (), + metaA ~ GDatatypeMetaOf repA, + Datatype metaA, + 'MetaCons symCtor fix hasSel ~ metaCtor, + Constructor metaCtor, + LiftedCtorToSymbol lCtor ~ symCtor, + 'Just '(metaCtor, '[ {meta_fields_constr}]) ~ GSpecCtorOf symCtor (Rep a ()){not_unpacked_constraints} + ) => GFill# lCtor '(metaCtor, '[ {meta_fields_head}]) a where + gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld + -> (# State# RealWorld, ({ty_dests}) #) + gFill# c# m# d# s0 = + case takeMVar# m# s0 of + (# s1, () #) -> + case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of + (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of + (# s3, pXInRegion# #) -> case getSlots{n}# xInRegion bH# bW# s3 of + (# s4, (# {raw_dests} #) #) -> case putMVar# m# () s4 of + s5 -> putDebugLn# + (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [{ptr_dests}]) + (# s5, ({dest_dests}) #) + {{-# INLINE gFill# #-}} +""" + +PADDING_META_FIELDS_CONSTR = " " * len(" 'Just '(metaCtor, '[ ") +PADDING_META_FIELDS_HEAD = " " * len(" ) => GFill# lCtor '(metaCtor, '[ ") + +BOUND = 7 + +script_dir = os.path.dirname(os.path.abspath(__file__)) +gfill_path = os.path.join(script_dir, "GFill.hs") + +# make write only so we can override if it exists +if os.path.exists(gfill_path): + os.chmod(gfill_path, 0o644) + +with open(gfill_path, "w", encoding="utf-8") as output_file: + output_file.write(HEADER) + for n in range(0, BOUND + 1): + meta_fields_constr = f",\n{PADDING_META_FIELDS_CONSTR}".join(f"'( 'MetaSel f{i} u{i} ss{i} ds{i}, t{i})" for i in range(n)) + not_unpacked_constraints = "".join(f",\n NotUnpacked ds{i}" for i in range(n)) + meta_fields_head = f",\n{PADDING_META_FIELDS_HEAD}".join(f"'( 'MetaSel f{i} u{i} ss{i} ds{i}, t{i})" for i in range(n)) + ty_dests = ", ".join(f"Dest r t{i}" for i in range(n)) + raw_dests = ", ".join(f"d{i}#" for i in range(n)) + ptr_dests = ", ".join(f"Ptr d{i}#" for i in range(n)) + dest_dests = ", ".join(f"Dest d{i}#" for i in range(n)) + output_file.write(INSTANCE.format( + n=n, + meta_fields_constr=meta_fields_constr, + not_unpacked_constraints=not_unpacked_constraints, + meta_fields_head=meta_fields_head, + ty_dests=ty_dests, + raw_dests=raw_dests, + ptr_dests=ptr_dests, + dest_dests=dest_dests + )) + +# make file read-only to prevent accidents +os.chmod(gfill_path, 0o444) \ No newline at end of file diff --git a/src-version-changes/ghc-dps-compact/after/Compact/Destination/Internal.hs b/src-version-changes/ghc-dps-compact/after/Compact/Destination/Internal.hs index 6701e12a..f3d466b5 100644 --- a/src-version-changes/ghc-dps-compact/after/Compact/Destination/Internal.hs +++ b/src-version-changes/ghc-dps-compact/after/Compact/Destination/Internal.hs @@ -65,6 +65,10 @@ offsetAddr# :: Word# -> Word# -> Addr# -> Word# -> Addr# offsetAddr# bH# bW# addr# fieldIdx# = word2Addr# (addr2Word# addr# `plusWord#` bH# `plusWord#` (bW# `timesWord#` fieldIdx#)) {-# INLINE offsetAddr# #-} +getSlots0# :: a -> Word# -> Word# -> State# RealWorld -> (# State# RealWorld, (# #) #) +getSlots0# _ _ _ s0 = (# s0, (# #) #) +{-# INLINE getSlots0# #-} + getSlots1# :: a -> Word# -> Word# -> State# RealWorld -> (# State# RealWorld, (# Addr# #) #) getSlots1# x bH# bW# s0 = case anyToAddr# x s0 of (# s1, pXRaw# #) -> let pX# = align# bW# pXRaw# in (# s1, (# offsetAddr# bH# bW# pX# 0## #) #) @@ -329,10 +333,6 @@ _fromIncomplete (Incomplete root uCompanion) = case getRegionInfo @r of data Dest r a = Dest Addr# -fill :: forall lCtor (r :: Type) (a :: Type). (Fill lCtor a, Region r) => Dest r a %1 -> DestsOf lCtor r a -fill = toLinear (_fill @lCtor @a @r) -{-# INLINE fill #-} - fillComp :: forall r a b. (Region r) => Incomplete r a b %1 -> Dest r a %1 -> b fillComp = toLinear2 _fillComp {-# INLINE fillComp #-} @@ -355,120 +355,12 @@ _fillComp (Incomplete root companion) (Dest d#) = case runRW# $ \s0 -> case assi (# _, res #) -> res {-# INLINE _fillComp #-} -class Fill lCtor (a :: Type) where - _fill :: forall (r :: Type). (Region r) => Dest r a -> DestsOf lCtor r a - -instance (specCtor ~ LiftedCtorToSpecCtor lCtor a, GFill# lCtor specCtor a) => Fill lCtor a where - _fill :: forall (r :: Type). (Region r) => Dest r a -> DestsOf lCtor r a - _fill (Dest d#) = case getRegionInfo @r of - (RegionInfo (Compact c# _ (MVar m#))) -> case runRW# (gFill# @lCtor @specCtor @a @r c# m# d#) of (# _, res #) -> res - {-# INLINE _fill #-} - --- ctor :: (Meta, [(Meta, Type)]) -class GFill# lCtor (specCtor :: (Meta, [(Meta, Type)])) (a :: Type) where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf specCtor r #) - -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, _, _ #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case putMVar# m# () s3 of - s4 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) []) (# s4, () #) - {-# INLINE gFill# #-} - --- TODO: add constraints on ds_i variables to ensure no unpacking -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0)]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0)]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0)]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case getSlots1# xInRegion bH# bW# s3 of - (# s4, (# d0# #) #) -> case putMVar# m# () s4 of - s5 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#]) (# s5, (Dest d0# :: Dest r t0) #) - {-# INLINE gFill# #-} - --- TODO: add constraints on ds_i variables to ensure no unpacking -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1)]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1)]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1)]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case getSlots2# xInRegion bH# bW# s3 of - (# s4, (# d0#, d1# #) #) -> case putMVar# m# () s4 of - s5 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#]) (# s5, (Dest d0# :: Dest r t0, Dest d1# :: Dest r t1) #) - {-# INLINE gFill# #-} - --- TODO: add constraints on ds_i variables to ensure no unpacking -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2)]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2)]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2)]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case getSlots3# xInRegion bH# bW# s3 of - (# s4, (# d0#, d1#, d2# #) #) -> case putMVar# m# () s4 of - s5 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#]) (# s5, (Dest d0# :: Dest r t0, Dest d1# :: Dest r t1, Dest d2# :: Dest r t2) #) - {-# INLINE gFill# #-} - --- TODO: add constraints on ds_i variables to ensure no unpacking -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3)]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3)]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3)]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case getSlots4# xInRegion bH# bW# s3 of - (# s4, (# d0#, d1#, d2#, d3# #) #) -> case putMVar# m# () s4 of - s5 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#]) (# s5, (Dest d0# :: Dest r t0, Dest d1# :: Dest r t1, Dest d2# :: Dest r t2, Dest d3# :: Dest r t3) #) - {-# INLINE gFill# #-} - --- TODO: add constraints on ds_i variables to ensure no unpacking -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4)]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4)]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4)]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case getSlots5# xInRegion bH# bW# s3 of - (# s4, (# d0#, d1#, d2#, d3#, d4# #) #) -> case putMVar# m# () s4 of - s5 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#]) (# s5, (Dest d0# :: Dest r t0, Dest d1# :: Dest r t1, Dest d2# :: Dest r t2, Dest d3# :: Dest r t3, Dest d4# :: Dest r t4) #) - {-# INLINE gFill# #-} - --- TODO: add constraints on ds_i variables to ensure no unpacking -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4), '( 'MetaSel f5 u5 ss5 ds5, t5)]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4), '( 'MetaSel f5 u5 ss5 ds5, t5)]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4), '( 'MetaSel f5 u5 ss5 ds5, t5)]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case getSlots6# xInRegion bH# bW# s3 of - (# s4, (# d0#, d1#, d2#, d3#, d4#, d5# #) #) -> case putMVar# m# () s4 of - s5 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#, Ptr d5#]) (# s5, (Dest d0# :: Dest r t0, Dest d1# :: Dest r t1, Dest d2# :: Dest r t2, Dest d3# :: Dest r t3, Dest d4# :: Dest r t4, Dest d5# :: Dest r t5) #) - {-# INLINE gFill# #-} - --- TODO: add constraints on ds_i variables to ensure no unpacking -instance (Generic a, repA ~ Rep a (), metaA ~ GDatatypeMetaOf repA, Datatype metaA, 'MetaCons symCtor fix hasSel ~ metaCtor, Constructor metaCtor, LiftedCtorToSymbol lCtor ~ symCtor, 'Just '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4), '( 'MetaSel f5 u5 ss5 ds5, t5), '( 'MetaSel f6 u6 ss6 ds6, t6)]) ~ GSpecCtorOf symCtor (Rep a ())) => GFill# lCtor '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4), '( 'MetaSel f5 u5 ss5 ds5, t5), '( 'MetaSel f6 u6 ss6 ds6, t6)]) a where - gFill# :: forall (r :: Type). Compact# -> MVar# RealWorld () -> Addr# -> State# RealWorld -> (# State# RealWorld, GDestsOf '(metaCtor, '[ '( 'MetaSel f0 u0 ss0 ds0, t0), '( 'MetaSel f1 u1 ss1 ds1, t1), '( 'MetaSel f2 u2 ss2 ds2, t2), '( 'MetaSel f3 u3 ss3 ds3, t3), '( 'MetaSel f4 u4 ss4 ds4, t4), '( 'MetaSel f5 u5 ss5 ds5, t5), '( 'MetaSel f6 u6 ss6 ds6, t6)]) r #) - gFill# c# m# d# s0 = - case takeMVar# m# s0 of - (# s1, () #) -> - case compactAddHollow# c# (unsafeCoerceAddr (reifyInfoTablePtr# (# #) :: InfoTablePtrOf# lCtor)) s1 of - (# s2, xInRegion, bH#, bW# #) -> case assign# d# xInRegion s2 of - (# s3, pXInRegion# #) -> case getSlots7# xInRegion bH# bW# s3 of - (# s4, (# d0#, d1#, d2#, d3#, d4#, d5#, d6# #) #) -> case putMVar# m# () s4 of - s5 -> putDebugLn# (showFill (Ptr d#) (Ptr pXInRegion#) (conName @metaCtor undefined) [Ptr d0#, Ptr d1#, Ptr d2#, Ptr d3#, Ptr d4#, Ptr d5#, Ptr d6#]) (# s5, (Dest d0# :: Dest r t0, Dest d1# :: Dest r t1, Dest d2# :: Dest r t2, Dest d3# :: Dest r t3, Dest d4# :: Dest r t4, Dest d5# :: Dest r t5, Dest d6# :: Dest r t6) #) - {-# INLINE gFill# #-} +type family NotUnpacked a :: Constraint where + NotUnpacked a = NotUnpacked_ a ('DecidedUnpack) + +type family NotUnpacked_ a b :: Constraint where + NotUnpacked_ a a = TypeError ('Text "Field has 'DecidedUnpack representation, which is not supported by fill") + NotUnpacked_ _ _ = () type family GDestsOf (specCtor :: (Meta, [(Meta, Type)])) (r :: Type) :: Type where GDestsOf '(_, '[]) _ = () @@ -507,7 +399,7 @@ type family GSpecCtorOf (symCtor :: Symbol) (repA :: Type) :: Maybe (Meta, [(Met GSpecCtorOf symCtor ((f :+: g) p) = GSpecCtorOf symCtor (f p) <|> GSpecCtorOf symCtor (g p) GSpecCtorOf symCtor (V1 _) = 'Nothing GSpecCtorOf symCtor (M1 _ _ f p) = GSpecCtorOf symCtor (f p) - GSpecCtorOf _ _ = TypeError ('Text "No match for GHasCtor") + GSpecCtorOf _ _ = TypeError ('Text "No match for GSpecCtorOf") type family LiftedCtorToSpecCtor lCtor (a :: Type) :: (Meta, [(Meta, Type)]) where LiftedCtorToSpecCtor lCtor a = FromJust (GSpecCtorOf (LiftedCtorToSymbol lCtor) (Rep a ()))