Fix toArgRep to support 64-bit reps on all systemswip/fix-64-toArgRep

[This is @Ericson2314 writing a commit message for @hsyl20's patch.]

(Progress towards #11953, #17377, #17375)

`Int64Rep` and `Word64Rep` are currently broken on 64-bit systems.  This
is because they should use "native arg rep" but instead use "large arg
rep" as they do on 32-bit systems, which is either a non-concept or a
128-bit rep depending on one's vantage point.

Now, these reps currently aren't used during 64-bit compilation, so the
brokenness isn't observed, but I don't think that constitutes reasons
not to fix it. Firstly, the linked issues there is a clearly expressed
desire to use explicit-bitwidth constructs in more places. Secondly, per
[1], there are other bugs that *do* manifest from not threading
explicit-bitwidth information all the way through the compilation
pipeline. One can therefore view this as one piece of the larger effort
to do that, improve ergnomics, and squash remaining bugs.

Also, this is needed for !3658. I could just merge this as part of that,
but I'm keen on merging fixes "as they are ready" so the fixes that
aren't ready are isolated and easier to debug.

[1]: https://mail.haskell.org/pipermail/ghc-devs/2020-October/019332.html

1 files changed, 39 insertions, 31 deletions

diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs
index f8cb9737d9..e9a7f81179 100644
--- a/compiler/GHC/CoreToByteCode.hs
+++ b/compiler/GHC/CoreToByteCode.hs
@@ -403,7 +403,7 @@ schemeR_wrk fvs nm original_body (args, body)
          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
 
          -- make the arg bitmap
-         bits = argBits platform (reverse (map bcIdArgRep all_args))
+         bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))
          bitmap_size = genericLength bits
          bitmap = mkBitmap platform bits
      body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -508,13 +508,17 @@ schemeE d s p e
 -- Delegate tail-calls to schemeT.
 schemeE d s p e@(AnnApp _ _) = schemeT d s p e
 
-schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
+schemeE d s p e@(AnnLit lit)     = do
+    platform <- profilePlatform <$> getProfile
+    returnUnboxedAtom d s p e (typeArgRep platform (literalType lit))
 schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
 
 schemeE d s p e@(AnnVar v)
       -- See Note [Not-necessarily-lifted join points], step 3.
     | isNNLJoinPoint v          = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
-    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
+    | isUnliftedType (idType v) = do
+        platform <- profilePlatform <$> getProfile
+        returnUnboxedAtom d s p e (bcIdArgRep platform v)
     | otherwise                 = schemeT d s p e
 
 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
@@ -830,18 +834,19 @@ schemeT d s p app
    -- Case 2: Constructor application
    | Just con <- maybe_saturated_dcon
    , isUnboxedTupleDataCon con
-   = case args_r_to_l of
-        [arg1,arg2] | isVAtom arg1 ->
+   = do
+     platform <- profilePlatform <$> getProfile
+     case args_r_to_l of
+        [arg1,arg2] | isVAtom platform arg1 ->
                   unboxedTupleReturn d s p arg2
-        [arg1,arg2] | isVAtom arg2 ->
+        [arg1,arg2] | isVAtom platform arg2 ->
                   unboxedTupleReturn d s p arg1
         _other -> multiValException
 
    -- Case 3: Ordinary data constructor
    | Just con <- maybe_saturated_dcon
    = do alloc_con <- mkConAppCode d s p con args_r_to_l
-        dflags <- getDynFlags
-        let platform = targetPlatform dflags
+        platform <- profilePlatform <$> getProfile
         return (alloc_con         `appOL`
                 mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`
                 ENTER)
@@ -922,7 +927,9 @@ mkConAppCode orig_d _ p con args_r_to_l =
 
 unboxedTupleReturn
     :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
+unboxedTupleReturn d s p arg = do
+   platform <- profilePlatform <$> getProfile
+   returnUnboxedAtom d s p arg (atomRep platform arg)
 
 -- -----------------------------------------------------------------------------
 -- Generate code for a tail-call
@@ -934,13 +941,14 @@ doTailCall
     -> Id
     -> [AnnExpr' Id DVarSet]
     -> BcM BCInstrList
-doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
+doTailCall init_d s p fn args = do
+   platform <- profilePlatform <$> getProfile
+   do_pushes init_d args (map (atomRep platform) args)
   where
   do_pushes !d [] reps = do
         ASSERT( null reps ) return ()
         (push_fn, sz) <- pushAtom d p (AnnVar fn)
-        dflags <- getDynFlags
-        let platform = targetPlatform dflags
+        platform <- profilePlatform <$> getProfile
         ASSERT( sz == wordSize platform ) return ()
         let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)
         return (push_fn `appOL` (slide `appOL` unitOL ENTER))
@@ -948,8 +956,7 @@ doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
       let (push_apply, n, rest_of_reps) = findPushSeq reps
           (these_args, rest_of_args) = splitAt n args
       (next_d, push_code) <- push_seq d these_args
-      dflags <- getDynFlags
-      let platform = targetPlatform dflags
+      platform <- profilePlatform <$> getProfile
       instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps
       --                          ^^^ for the PUSH_APPLY_ instruction
       return (push_code `appOL` (push_apply `consOL` instrs))
@@ -1137,8 +1144,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
           -- NB: unboxed tuple cases bind the scrut binder to the same offset
           -- as one of the alt binders, so we have to remove any duplicates here:
           rel_slots = nub $ map fromIntegral $ concatMap spread binds
-          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
-                              | otherwise                      = []
+          spread (id, offset) | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]
+                              | otherwise                                = []
                 where rel_offset = trunc16W $ bytesToWords platform (d - offset)
 
      alt_stuff <- mapM codeAlt alts
@@ -1157,7 +1164,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
      alt_bco' <- emitBc alt_bco
      let push_alts
             | isAlgCase = PUSH_ALTS alt_bco'
-            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep platform bndr_ty)
      return (push_alts `consOL` scrut_code)
 
 
@@ -1374,7 +1381,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- slide and return
          d_after_r_min_s = bytesToWords platform (d_after_r - s)
          wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
-                        `snocOL` RETURN_UBX (toArgRep r_rep)
+                        `snocOL` RETURN_UBX (toArgRep platform r_rep)
          --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
      return (
          push_args `appOL`
@@ -1827,13 +1834,13 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
 lookupBCEnv_maybe = Map.lookup
 
 idSizeW :: Platform -> Id -> WordOff
-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep
+idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
 
 idSizeCon :: Platform -> Id -> ByteOff
 idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep
 
-bcIdArgRep :: Id -> ArgRep
-bcIdArgRep = toArgRep . bcIdPrimRep
+bcIdArgRep :: Platform -> Id -> ArgRep
+bcIdArgRep platform = toArgRep platform . bcIdPrimRep
 
 bcIdPrimRep :: Id -> PrimRep
 bcIdPrimRep id
@@ -1843,7 +1850,7 @@ bcIdPrimRep id
   = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
 
 repSizeWords :: Platform -> PrimRep -> WordOff
-repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)
+repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
 
 isFollowableArg :: ArgRep -> Bool
 isFollowableArg P = True
@@ -1930,11 +1937,12 @@ bcViewLoop e =
       Nothing -> e
       Just e' -> bcViewLoop e'
 
-isVAtom :: AnnExpr' Var ann -> Bool
-isVAtom e | Just e' <- bcView e = isVAtom e'
-isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)
-isVAtom (AnnCoercion {})        = True
-isVAtom _                     = False
+isVAtom :: Platform -> AnnExpr' Var ann -> Bool
+isVAtom platform expr = case expr of
+   e | Just e' <- bcView e -> isVAtom platform e'
+   (AnnVar v)              -> isVoidArg (bcIdArgRep platform v)
+   (AnnCoercion {})        -> True
+   _                       -> False
 
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
@@ -1949,8 +1957,8 @@ atomPrimRep (AnnCase _ _ ty _)      =
 atomPrimRep (AnnCoercion {})        = VoidRep
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
 
-atomRep :: AnnExpr' Id ann -> ArgRep
-atomRep e = toArgRep (atomPrimRep e)
+atomRep :: Platform -> AnnExpr' Id ann -> ArgRep
+atomRep platform e = toArgRep platform (atomPrimRep e)
 
 -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
 -- has initial depth @original_depth@.  Return the values which the stack
@@ -1958,8 +1966,8 @@ atomRep e = toArgRep (atomPrimRep e)
 mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
 mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
 
-typeArgRep :: Type -> ArgRep
-typeArgRep = toArgRep . typePrimRep1
+typeArgRep :: Platform -> Type -> ArgRep
+typeArgRep platform = toArgRep platform . typePrimRep1
 
 -- -----------------------------------------------------------------------------
 -- The bytecode generator's monad