[Git][ghc/ghc][wip/buggymcbugfix/arrayOf-primop] Implement `arrayOf#`

[Vilem-Benjamin Liepelt]

Vilem-Benjamin Liepelt pushed to branch wip/buggymcbugfix/arrayOf-primop at Glasgow Haskell Compiler / GHC


Commits:
9995769c by buggymcbugfix at 2020-08-20T17:54:44+02:00
Implement `arrayOf#`

- - - - -


3 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/StgToCmm/Closure.hs
- compiler/GHC/StgToCmm/Prim.hs


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -1247,9 +1247,15 @@ primop  NewSmallArrayOp "newSmallArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
+primop ArrayOfOp "arrayOf#" GenPrimOp
+   o -> Array# b
+   {arrayOf# :: (# a, .., a #) -> Array# a}
+   with
+   has_side_effects = True
+
 primop SmallArrayOfOp "smallArrayOf#" GenPrimOp
    o -> SmallArray# b
-   {smallArrayOf# :: (# a, .., a #) -> Array# a}
+   {smallArrayOf# :: (# a, .., a #) -> SmallArray# a}
    with
    has_side_effects = True
 


=====================================
compiler/GHC/StgToCmm/Closure.hs
=====================================
@@ -60,7 +60,6 @@ module GHC.StgToCmm.Closure (
         cafBlackHoleInfoTable,
         indStaticInfoTable,
         staticClosureNeedsLink,
-        smallArrayStaticInfoTable,
     ) where
 
 #include "HsVersions.h"
@@ -987,14 +986,6 @@ indStaticInfoTable
                  , cit_srt  = Nothing
                  , cit_clo  = Nothing }
 
-smallArrayStaticInfoTable :: WordOff -> CmmInfoTable
-smallArrayStaticInfoTable n
-  = CmmInfoTable { cit_lbl  = mkSMAP_FROZEN_DIRTY_infoLabel
-                 , cit_rep  = smallArrPtrsRep (fromIntegral n)
-                 , cit_prof = NoProfilingInfo
-                 , cit_srt  = Nothing
-                 , cit_clo  = Nothing }
-
 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- A static closure needs a link field to aid the GC when traversing
 -- the static closure graph.  But it only needs such a field if either


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 #if __GLASGOW_HASKELL__ <= 808
 -- GHC 8.10 deprecates this flag, but GHC 8.8 needs it
@@ -58,7 +59,6 @@ import Data.Bits ((.&.), bit)
 import Control.Monad (liftM, when, unless)
 
 import GHC.Types.CostCentre (dontCareCCS)
-import GHC.StgToCmm.Closure
 
 ------------------------------------------------------------------------
 --      Primitive operations and foreign calls
@@ -244,27 +244,9 @@ emitPrimOp dflags = \case
         (replicate (fromIntegral n) init)
     _ -> PrimopCmmEmit_External
 
-  op at SmallArrayOfOp -> \elems -> PrimopCmmEmit_IntoRegs $ \[res] -> do
-    let n = length elems
-    case allStatic elems of
-      Just known -> do
-        u <- newUnique
-        let lbl = mkUnliftedDataLabel u op
-        emitDataCon lbl (smallArrayStaticInfoTable n) dontCareCCS known
-        emit $ mkAssign (CmmLocal res) (CmmLit $ CmmLabel lbl)
-      Nothing -> doNewArrayOp
-        res
-        (smallArrPtrsRep (fromIntegral n))
-        mkSMAP_FROZEN_DIRTY_infoLabel
-        [ ( mkIntExpr platform n
-          , fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags ) ]
-        elems
-      where
-        -- todo: comment
-        allStatic = foldr step (Just [])
+  op at ArrayOfOp -> doArrayOfOp dflags op
 
-        step (CmmLit l) (Just acc) = Just (l : acc) -- c.f. XXX getLit
-        step _ _ = Nothing
+  op at SmallArrayOfOp -> doArrayOfOp dflags op
 
   CopySmallArrayOp -> \case
     [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
@@ -2577,6 +2559,61 @@ doNewArrayOp res_r rep info payload inits = do
 
     emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
 
+doArrayOfOp :: DynFlags -> PrimOp -> [CmmExpr] -> PrimopCmmEmit
+doArrayOfOp dflags op = \elems -> PrimopCmmEmit_IntoRegs $ \[res] -> do
+    let
+      n :: Int
+      n = length elems
+
+      platform :: Platform
+      platform = targetPlatform dflags
+
+      infoTbl :: CmmInfoTable
+      infoTbl = CmmInfoTable
+          { cit_lbl  = lbl
+          , cit_rep  = rep
+          , cit_prof = NoProfilingInfo
+          , cit_srt  = Nothing
+          , cit_clo  = Nothing }
+
+      lbl :: CLabel
+      rep :: SMRep
+      hdr :: [(CmmExpr, ByteOff)]
+      (lbl, rep, hdr) = case op of
+        ArrayOfOp ->
+          ( mkMAP_FROZEN_DIRTY_infoLabel
+          , arrPtrsRep dflags (fromIntegral n)
+          , [ ( mkIntExpr platform n
+              , fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags )
+            , ( mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags n))
+              , fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags )
+            ]
+          )
+        SmallArrayOfOp ->
+          ( mkSMAP_FROZEN_DIRTY_infoLabel
+          , smallArrPtrsRep (fromIntegral n)
+          , [ ( mkIntExpr platform n
+              , fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags
+              )
+            ]
+          )
+        _ -> error "Expected one of: ArrayOfOp, SmallArrayOfOp"
+
+    if all isStatic elems
+      then do
+        u <- newUnique
+        let staticLbl = mkUnliftedDataLabel u op
+        emitDataCon staticLbl infoTbl dontCareCCS (map unsafeUnwrapLit elems)
+        emit $ mkAssign (CmmLocal res) (CmmLit $ CmmLabel staticLbl)
+      else doNewArrayOp res rep lbl hdr elems
+
+isStatic :: CmmExpr -> Bool
+isStatic = \case CmmLit{} -> True; _ -> False
+
+unsafeUnwrapLit :: CmmExpr -> CmmLit
+unsafeUnwrapLit (CmmLit i) = i
+unsafeUnwrapLit _ = error "Expected CmmLit"
+
 -- ----------------------------------------------------------------------------
 -- Copying pointer arrays
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9995769c61751476e33a6f17ee307045cd9cb9bc

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9995769c61751476e33a6f17ee307045cd9cb9bc
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200824/167c5cf6/attachment-0001.html>