Compact Regions

This brings in initial support for compact regions, as described in the
ICFP 2015 paper "Efficient Communication and Collection with Compact
Normal Forms" (Edward Z. Yang et.al.) and implemented by Giovanni
Campagna.

Some things may change before the 8.2 release, but I (Simon M.) wanted
to get the main patch committed so that we can iterate.

What documentation there is is in the Data.Compact module in the new
compact package.  We'll need to extend and polish the documentation
before the release.

Test Plan:
validate
(new test cases included)

Reviewers: ezyang, simonmar, hvr, bgamari, austin

Subscribers: vikraman, Yuras, RyanGlScott, qnikst, mboes, facundominguez, rrnewton, thomie, erikd

Differential Revision: https://phabricator.haskell.org/D1264

GHC Trac Issues: #11493

4 files changed, 126 insertions, 3 deletions

diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 84f263cc3c..d3c09c584e 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -351,7 +351,6 @@ emitPrimOp dflags [res] EqStableNameOp [arg1,arg2]
                                    cmmLoadIndexW dflags arg2 (fixedHdrSizeW dflags) (bWord dflags)
                          ])
 
-
 emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
    = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
 
@@ -359,6 +358,10 @@ emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
 emitPrimOp _      [res] AddrToAnyOp [arg]
    = emitAssign (CmmLocal res) arg
 
+--  #define hvalueToAddrzh(r, a) r=(W_)a
+emitPrimOp _      [res] AnyToAddrOp [arg]
+   = emitAssign (CmmLocal res) arg
+
 --  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
 --  Note: argument may be tagged!
 emitPrimOp dflags [res] DataToTagOp [arg]
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 483006f638..4d5e378f57 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -1579,7 +1579,8 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
-    eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey :: Unique
+    eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey,
+    compactPrimTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
@@ -1608,6 +1609,7 @@ bcoPrimTyConKey                         = mkPreludeTyConUnique 74
 ptrTyConKey                             = mkPreludeTyConUnique 75
 funPtrTyConKey                          = mkPreludeTyConUnique 76
 tVarPrimTyConKey                        = mkPreludeTyConUnique 77
+compactPrimTyConKey                     = mkPreludeTyConUnique 78
 
 -- Parallel array type constructor
 parrTyConKey :: Unique
diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs
index 376a0bbe43..19728ee430 100644
--- a/compiler/prelude/TysPrim.hs
+++ b/compiler/prelude/TysPrim.hs
@@ -59,6 +59,7 @@ module TysPrim(
         tVarPrimTyCon,                  mkTVarPrimTy,
         stablePtrPrimTyCon,             mkStablePtrPrimTy,
         stableNamePrimTyCon,            mkStableNamePrimTy,
+        compactPrimTyCon,               compactPrimTy,
         bcoPrimTyCon,                   bcoPrimTy,
         weakPrimTyCon,                  mkWeakPrimTy,
         threadIdPrimTyCon,              threadIdPrimTy,
@@ -138,6 +139,7 @@ primTyCons
     , realWorldTyCon
     , stablePtrPrimTyCon
     , stableNamePrimTyCon
+    , compactPrimTyCon
     , statePrimTyCon
     , voidPrimTyCon
     , proxyPrimTyCon
@@ -170,7 +172,7 @@ mkBuiltInPrimTc fs unique tycon
                   BuiltInSyntax
 
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
 charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName            = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -201,6 +203,7 @@ mVarPrimTyConName             = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPr
 tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon
 stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon
 stableNamePrimTyConName       = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon
+compactPrimTyConName          = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon
 bcoPrimTyConName              = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon
 weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
 threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
@@ -893,6 +896,20 @@ mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty]
 {-
 ************************************************************************
 *                                                                      *
+\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type}
+*                                                                      *
+************************************************************************
+-}
+
+compactPrimTyCon :: TyCon
+compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName PtrRep
+
+compactPrimTy :: Type
+compactPrimTy = mkTyConTy compactPrimTyCon
+
+{-
+************************************************************************
+*                                                                      *
 \subsection[TysPrim-BCOs]{The ``bytecode object'' type}
 *                                                                      *
 ************************************************************************
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index bfeb7852c6..9fd5d17f14 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -2426,6 +2426,92 @@ primop  StableNameToIntOp "stableNameToInt#" GenPrimOp
    StableName# a -> Int#
 
 ------------------------------------------------------------------------
+section "Compact normal form"
+------------------------------------------------------------------------
+
+primtype Compact#
+
+primop  CompactNewOp "compactNew#" GenPrimOp
+   Word# -> State# RealWorld -> (# State# RealWorld, Compact# #)
+   { Create a new Compact with the given size (in bytes, not words).
+     The size is rounded up to a multiple of the allocator block size,
+     and capped to one mega block. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+primop  CompactAppendOp "compactAppend#" GenPrimOp
+   Compact# -> a -> Int# -> State# RealWorld -> (# State# RealWorld, a #)
+   { Append an object to a compact, return the new address in the Compact.
+     The third argument is 1 if sharing should be preserved, 0 otherwise. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+primop  CompactResizeOp "compactResize#" GenPrimOp
+   Compact# -> Word# -> State# RealWorld ->
+   State# RealWorld
+   { Set the new allocation size of the compact. This value (in bytes)
+     determines the size of each block in the compact chain. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+primop  CompactContainsOp "compactContains#" GenPrimOp
+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)
+   { Returns 1# if the object is contained in the compact, 0# otherwise. }
+   with
+   out_of_line      = True
+
+primop  CompactContainsAnyOp "compactContainsAny#" GenPrimOp
+   a -> State# RealWorld -> (# State# RealWorld, Int# #)
+   { Returns 1# if the object is in any compact at all, 0# otherwise. }
+   with
+   out_of_line      = True
+
+primop  CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp
+   Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
+   { Returns the address and the size (in bytes) of the first block of
+     a compact. }
+   with
+   out_of_line      = True
+
+primop  CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp
+   Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)
+   { Given a compact and the address of one its blocks, returns the
+     next block and its size, or #nullAddr if the argument was the
+     last block in the compact. }
+   with
+   out_of_line      = True
+
+primop  CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp
+   Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)
+   { Attempt to allocate a compact block with the given size (in
+     bytes) at the given address. The first argument is a hint to
+     the allocator, allocation might be satisfied at a different
+     address (which is returned).
+     The resulting block is not known to the GC until
+     compactFixupPointers# is called on it, and care must be taken
+     so that the address does not escape or memory will be leaked.
+   }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+primop  CompactFixupPointersOp "compactFixupPointers#" GenPrimOp
+   Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #)
+   { Given the pointer to the first block of a compact, and the
+     address of the root object in the old address space, fix up
+     the internal pointers inside the compact to account for
+     a different position in memory than when it was serialized.
+     This method must be called exactly once after importing
+     a serialized compact, and returns the new compact and
+     the new adjusted root address. }
+   with
+   has_side_effects = True
+   out_of_line      = True
+
+------------------------------------------------------------------------
 section "Unsafe pointer equality"
 --  (#1 Bad Guy: Alistair Reid :)
 ------------------------------------------------------------------------
@@ -2507,6 +2593,21 @@ primop   AddrToAnyOp "addrToAny#" GenPrimOp
    with
    code_size = 0
 
+primop   AnyToAddrOp "anyToAddr#" GenPrimOp
+   a -> State# RealWorld -> (# State# RealWorld, Addr# #)
+   { Retrive the address of any Haskell value. This is
+     essentially an {\texttt unsafeCoerce\#}, but if implemented as such
+     the core lint pass complains and fails to compile.
+     As a primop, it is opaque to core/stg, and only appears
+     in cmm (where the copy propagation pass will get rid of it).
+     Note that "a" must be a value, not a thunk! It's too late
+     for strictness analysis to enforce this, so you're on your
+     own to guarantee this. Also note that {\texttt Addr\#} is not a GC
+     pointer - up to you to guarantee that it does not become
+     a dangling pointer immediately after you get it.}
+   with
+   code_size = 0
+
 primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp
    BCO# -> (# a #)
    { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of