Fix toArgRep to support 64-bit reps on all systems

[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

6 files changed, 81 insertions, 65 deletions

diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs
index 9982436429..b82dd5cb26 100644
--- a/compiler/GHC/Core/TyCon.hs
+++ b/compiler/GHC/Core/TyCon.hs
@@ -1440,12 +1440,12 @@ data PrimRep
   | Int8Rep       -- ^ Signed, 8-bit value
   | Int16Rep      -- ^ Signed, 16-bit value
   | Int32Rep      -- ^ Signed, 32-bit value
-  | Int64Rep      -- ^ Signed, 64 bit value (with 32-bit words only)
+  | Int64Rep      -- ^ Signed, 64 bit value
   | IntRep        -- ^ Signed, word-sized value
   | Word8Rep      -- ^ Unsigned, 8 bit value
   | Word16Rep     -- ^ Unsigned, 16 bit value
   | Word32Rep     -- ^ Unsigned, 32 bit value
-  | Word64Rep     -- ^ Unsigned, 64 bit value (with 32-bit words only)
+  | Word64Rep     -- ^ Unsigned, 64 bit value
   | WordRep       -- ^ Unsigned, word-sized value
   | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')
   | FloatRep
diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs
index 96c7ea9dec..e993688db9 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`
@@ -1854,13 +1861,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
@@ -1870,7 +1877,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
@@ -1957,11 +1964,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'
@@ -1976,8 +1984,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
@@ -1985,8 +1993,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
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
index def06c6102..5aef95c008 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ b/compiler/GHC/Stg/Lift/Analysis.hs
@@ -497,7 +497,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla
 idClosureFootprint:: Platform -> Id -> WordOff
 idClosureFootprint platform
   = StgToCmm.ArgRep.argRepSizeW platform
-  . StgToCmm.ArgRep.idArgRep
+  . StgToCmm.ArgRep.idArgRep platform
 
 -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
 -- as a result of lifting @f@ to top-level. If there was any growing closure
diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs
index 4d85d23d17..8fc1796d6f 100644
--- a/compiler/GHC/StgToCmm/ArgRep.hs
+++ b/compiler/GHC/StgToCmm/ArgRep.hs
@@ -65,28 +65,33 @@ argRepString V16 = "V16"
 argRepString V32 = "V32"
 argRepString V64 = "V64"
 
-toArgRep :: PrimRep -> ArgRep
-toArgRep VoidRep           = V
-toArgRep LiftedRep         = P
-toArgRep UnliftedRep       = P
-toArgRep IntRep            = N
-toArgRep WordRep           = N
-toArgRep Int8Rep           = N  -- Gets widened to native word width for calls
-toArgRep Word8Rep          = N  -- Gets widened to native word width for calls
-toArgRep Int16Rep          = N  -- Gets widened to native word width for calls
-toArgRep Word16Rep         = N  -- Gets widened to native word width for calls
-toArgRep Int32Rep          = N  -- Gets widened to native word width for calls
-toArgRep Word32Rep         = N  -- Gets widened to native word width for calls
-toArgRep AddrRep           = N
-toArgRep Int64Rep          = L
-toArgRep Word64Rep         = L
-toArgRep FloatRep          = F
-toArgRep DoubleRep         = D
-toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of
-                               16 -> V16
-                               32 -> V32
-                               64 -> V64
-                               _  -> error "toArgRep: bad vector primrep"
+toArgRep :: Platform -> PrimRep -> ArgRep
+toArgRep platform rep = case rep of
+   VoidRep           -> V
+   LiftedRep         -> P
+   UnliftedRep       -> P
+   IntRep            -> N
+   WordRep           -> N
+   Int8Rep           -> N  -- Gets widened to native word width for calls
+   Word8Rep          -> N  -- Gets widened to native word width for calls
+   Int16Rep          -> N  -- Gets widened to native word width for calls
+   Word16Rep         -> N  -- Gets widened to native word width for calls
+   Int32Rep          -> N  -- Gets widened to native word width for calls
+   Word32Rep         -> N  -- Gets widened to native word width for calls
+   AddrRep           -> N
+   Int64Rep          -> case platformWordSize platform of
+                           PW4 -> L
+                           PW8 -> N
+   Word64Rep         -> case platformWordSize platform of
+                           PW4 -> L
+                           PW8 -> N
+   FloatRep          -> F
+   DoubleRep         -> D
+   (VecRep len elem) -> case len*primElemRepSizeB elem of
+                           16 -> V16
+                           32 -> V32
+                           64 -> V64
+                           _  -> error "toArgRep: bad vector primrep"
 
 isNonV :: ArgRep -> Bool
 isNonV V = False
@@ -106,8 +111,8 @@ argRepSizeW platform = \case
   where
    ws       = platformWordSizeInBytes platform
 
-idArgRep :: Id -> ArgRep
-idArgRep = toArgRep . idPrimRep
+idArgRep :: Platform -> Id -> ArgRep
+idArgRep platform = toArgRep platform . idPrimRep
 
 -- This list of argument patterns should be kept in sync with at least
 -- the following:
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
index 70a9fc8fe7..88e77b3782 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ b/compiler/GHC/StgToCmm/Layout.hs
@@ -321,12 +321,14 @@ direct_call caller call_conv lbl arity args
 -- using zeroCLit or even undefined would work, but would be ugly).
 --
 getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
-getArgRepsAmodes = mapM getArgRepAmode
-  where getArgRepAmode arg
+getArgRepsAmodes args = do
+   platform <- profilePlatform <$> getProfile
+   mapM (getArgRepAmode platform) args
+  where getArgRepAmode platform arg
            | V <- rep  = return (V, Nothing)
            | otherwise = do expr <- getArgAmode (NonVoid arg)
                             return (rep, Just expr)
-           where rep = toArgRep (argPrimRep arg)
+           where rep = toArgRep platform (argPrimRep arg)
 
 nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
 nonVArgs [] = []
@@ -542,7 +544,7 @@ mkVirtConstrSizes profile field_reps
 mkArgDescr :: Platform -> [Id] -> ArgDescr
 mkArgDescr platform args
   = let arg_bits = argBits platform arg_reps
-        arg_reps = filter isNonV (map idArgRep args)
+        arg_reps = filter isNonV (map (idArgRep platform) args)
            -- Getting rid of voids eases matching of standard patterns
     in case stdPattern arg_reps of
          Just spec_id -> ArgSpec spec_id
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
index b7f43665cd..44a99a0cae 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -409,10 +409,11 @@ tickySlowCall lf_info args = do
  tickySlowCallPat (map argPrimRep args)
 
 tickySlowCallPat :: [PrimRep] -> FCode ()
-tickySlowCallPat args = ifTicky $
-  let argReps = map toArgRep args
+tickySlowCallPat args = ifTicky $ do
+  platform <- profilePlatform <$> getProfile
+  let argReps = map (toArgRep platform) args
       (_, n_matched) = slowCallPattern argReps
-  in if n_matched > 0 && args `lengthIs` n_matched
+  if n_matched > 0 && args `lengthIs` n_matched
      then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
      else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"