combine alts morewip/andreask/outlining_alts

9 files changed, 208 insertions, 49 deletions

diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 96d4df976a..8cee6d0021 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -3016,8 +3016,6 @@ simplAlts env0 scrut case_bndr alts cont'
         ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
         ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
 
-        -- ; (alt_floats,alts'') <- doAlts alt_env' case_bndr' alts'
-
         ; let alts_ty' = contResultType cont'
 
         ; final_case <- mkCase (seDynFlags env0) alt_env' scrut' case_bndr' alts_ty' alts'
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 75b851e6a8..b525189cea 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -86,6 +86,9 @@ import GHC.Core.Make ( mkCoreApps, mkCoreLams )
 import GHC.Data.TrieMap (elemsTM)
 import GHC.Core.Stats (exprSize)
 import GHC.Utils.Constants (debugIsOn)
+import GHC.Types.Id.Make (voidArgId, voidPrimId)
+import GHC.Types.RepType (isVoidTy)
+import GHC.Builtin.Types (unboxedUnitTy)
 
 {-
 ************************************************************************
@@ -2142,7 +2145,6 @@ prepareAlts scrut case_bndr' alts
              -- i.e. the constructors that can't match the default case
        ; when yes2 $ tick (FillInCaseDefault case_bndr')
        ; when yes3 $ tick (AltMerge case_bndr')
-      --  ; doAlts case_bndr' alts
        ; return (idcs3, alts3) }
 
   | otherwise  -- Not a data type, so nothing interesting happens
@@ -2499,15 +2501,32 @@ doAlts env case_bndr alts_in = do
         -- There are alts to combine, create a join point representing the rhs.
         | (alt1@Alt{alt_bndrs = alt1_bndrs, alt_rhs = alt1_rhs}:_) <- combined_in
         = do
-            let -- Binders the join point might close over.
+            let --shared_bnds = case_bndr:alt1_bndrs
+                -- -- FVs of the rhs
+                -- fvs = exprFreeVars (alt1_rhs)
+                -- -- Which of the binders do we *actually* close over.
+                -- used_shared = map (`elemVarSet` fvs) shared_bnds :: [Bool]
+
+                -- rhs_args     = filterByList used_shared shared_bnds
+                -- alt_args alt = filterByList used_shared (map Var (case_bndr : alt_bndrs alt))
+                -- shared_rhs_expr = -- pprTraceIt "shared_rhs" $
+                --                   mkCoreLams rhs_args (alt1_rhs)
+                -- arity = length rhs_args
+
+
+                -- Binders the join point might close over.
                 shared_bnds = case_bndr:alt1_bndrs
-                -- FVs of the rhs
-                fvs = exprFreeVars (alt1_rhs)
-                -- Which of the binders do we *actually* close over.
-                used_shared = map (`elemVarSet` fvs) shared_bnds :: [Bool]
 
-                rhs_args     = filterByList used_shared shared_bnds
-                alt_args alt = filterByList used_shared (map Var (case_bndr : alt_bndrs alt))
+                -- FVs of the rhs which are the case binder or bound by a constructor.
+            let case_bound_fvs = filter (`elem` shared_bnds) $ exprFreeVarsList (alt1_rhs)
+
+                rhs_args = case_bound_fvs
+                alt_args alt =
+                    let shared_bnds_a = case_bndr:(alt_bndrs alt)
+                        -- This seems a bit expensive.
+                        alt_bound_fvs = filter (`elem` shared_bnds_a) $ exprFreeVarsList (alt_rhs alt)
+                        alt_call_args = alt_bound_fvs
+                    in map Var alt_call_args
                 shared_rhs_expr = -- pprTraceIt "shared_rhs" $
                                   mkCoreLams rhs_args (alt1_rhs)
                 arity = length rhs_args
@@ -2533,7 +2552,7 @@ doAlts env case_bndr alts_in = do
               pprTraceM "combined_alts" ( text "alt_count:" <> ppr (length new_alts) $$
                                           text "alt_size:" <> ppr (exprSize alt1_rhs) $$
                                           text "alt_elim:" <> ppr ((length new_alts - 1) * exprSize alt1_rhs) $$
-                                          text "used_vars:" <> ppr (used_shared) $$
+                                          text "used_vars:" <> ppr (case_bound_fvs) $$
                                           text "alt_args1" <> ppr (alt_args alt1) $$
                                           text "old_rhs:" <> ppr alt1_rhs $$
 
@@ -2559,7 +2578,7 @@ doAlts env case_bndr alts_in = do
 
       -- Adds one alternative to the map
       extendMap :: CoreMap [CoreAlt] -> CoreAlt -> CoreMap [CoreAlt]
-      extendMap m alt = alterTM (mkCoreLams (alt_bndrs alt) (alt_rhs alt)) update m
+      extendMap m alt = alterTM ((alt_rhs alt)) update m
         where update Nothing = Just [alt]
               update (Just cs) = Just (alt:cs)
 
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index c2287916db..a88f3d8d45 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -377,8 +377,8 @@ We use the state-token type which generates no code.
 -}
 
 mkWorkerArgs :: Id      -- The wrapper Id
-             -> Bool
-             -> [Var]
+             -> Bool    -- Allows fun-to-thunk
+             -> [Var]   -- Args
              -> Type    -- Type of body
              -> ([Var], -- Lambda bound args
                  [Var]) -- Args at call site
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
index 7d89b71309..9e3921a875 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ b/compiler/GHC/StgToCmm/Bind.hs
@@ -62,6 +62,7 @@ import GHC.Data.FastString
 import GHC.Data.List.SetOps
 
 import Control.Monad
+import GHC.Utils.Panic.Plain (assert, assertM)
 
 ------------------------------------------------------------------------
 --              Top-level bindings
@@ -479,6 +480,7 @@ closureCodeBody top_lvl bndr cl_info cc [] body fv_details
      lf_info  = closureLFInfo cl_info
      info_tbl = mkCmmInfo cl_info bndr cc
 
+-- A function.
 closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
   = let nv_args = nonVoidIds args
         arity = length args
@@ -539,8 +541,11 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
 
 -- A function closure pointer may be tagged, so we
 -- must take it into account when accessing the free variables.
-bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
-bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
+bind_fv :: HasCallStack => (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
+bind_fv (id, off) = do { massertPpr (not (isJoinId (fromNonVoid id)))
+                            (text "Re-Binding join id to register:" <> ppr id $$
+                             text "Is a join point being used inside a thunk?")
+                       ; reg <- rebindToReg id; return (reg, off) }
 
 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
 load_fvs node lf_info = mapM_ (\ (reg, off) ->
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 3ff745a719..1a327ca20d 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -498,9 +498,12 @@ data CallOpts = CallOpts
    , co_ticky         :: !Bool      -- ^ Ticky profiling enabled (cf @-ticky@)
    }
 
+call_platform :: CallOpts -> Platform
+call_platform = profilePlatform . co_profile
+
 getCallMethod :: CallOpts
               -> Name           -- Function being applied
-              -> Id             -- Function Id used to chech if it can refer to
+              -> Id             -- Function Id used to check if it can refer to
                                 -- CAF's and whether the function is tail-calling
                                 -- itself
               -> LambdaFormInfo -- Its info
@@ -587,7 +590,7 @@ getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
               _self_loop_info
   = JumpToIt blk_id lne_regs
 
-getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
+getCallMethod opts _ id lf_info _ _ cg_loc _ = pprPanic "Unknown call method" (ppr id <+> ppr lf_info <+> pdoc (call_platform opts) cg_loc)
 
 -----------------------------------------------------------------------------
 --              Data types for closure information
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
index f28f0d0ec2..3c9e948f1c 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ b/compiler/GHC/StgToCmm/Env.hs
@@ -45,6 +45,8 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 
 import GHC.Driver.Session
+import GHC.Utils.Trace
+import GHC.Stack.Types (HasCallStack)
 
 
 -------------------------------------
@@ -74,7 +76,7 @@ lneIdInfo platform id regs
 
 rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
 rhsIdInfo id lf_info
-  = do platform <- getPlatform
+  = do platform <- targetPlatform <$> getDynFlags
        reg <- newTemp (gcWord platform)
        return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
 
@@ -105,9 +107,11 @@ maybeLetNoEscape _other                                      = Nothing
 -- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
 ---------------------------------------------------------
 
-addBindC :: CgIdInfo -> FCode ()
+addBindC :: HasCallStack => CgIdInfo -> FCode ()
 addBindC stuff_to_bind = do
         binds <- getBinds
+        p <- targetPlatform <$> getDynFlags
+        pprTraceM "addBind" (pdoc p stuff_to_bind <+> traceCallStackDoc)
         setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
 
 addBindsC :: [CgIdInfo] -> FCode ()
@@ -120,30 +124,34 @@ addBindsC new_bindings = do
 
 getCgIdInfo :: Id -> FCode CgIdInfo
 getCgIdInfo id
-  = do  { platform <- targetPlatform <$> getDynFlags
-        ; local_binds <- getBinds -- Try local bindings first
-        ; case lookupVarEnv local_binds id of {
-            Just info -> return info ;
-            Nothing   -> do {
-
-                -- Should be imported; make up a CgIdInfo for it
-          let name = idName id
-        ; if isExternalName name then
-              let ext_lbl
-                      | isBoxedType (idType id)
-                      = mkClosureLabel name $ idCafInfo id
-                      | isUnliftedType (idType id)
-                          -- An unlifted external Id must refer to a top-level
-                          -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".
-                      = assert (idType id `eqType` addrPrimTy) $
-                        mkBytesLabel name
-                      | otherwise
-                      = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))
-              in return $
-                  litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl)
-          else
-              cgLookupPanic id -- Bug
-        }}}
+  = do
+      r <- do  { platform <- targetPlatform <$> getDynFlags
+                  ; local_binds <- getBinds -- Try local bindings first
+                  ; case lookupVarEnv local_binds id of {
+                      Just info -> return info ;
+                      Nothing   -> do {
+
+                          -- Should be imported; make up a CgIdInfo for it
+                    let name = idName id
+                  ; if isExternalName name then
+                        let ext_lbl
+                                | isBoxedType (idType id)
+                                = mkClosureLabel name $ idCafInfo id
+                                | isUnliftedType (idType id)
+                                    -- An unlifted external Id must refer to a top-level
+                                    -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".
+                                = assert (idType id `eqType` addrPrimTy) $
+                                  mkBytesLabel name
+                                | otherwise
+                                = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))
+                        in return $
+                            litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl)
+                    else
+                        cgLookupPanic id -- Bug
+                  }}}
+      p <- targetPlatform <$> getDynFlags
+      pprTraceM "getCgInfo" (ppr id <+> pdoc p r)
+      return r
 
 cgLookupPanic :: Id -> FCode a
 cgLookupPanic id
@@ -160,7 +168,7 @@ cgLookupPanic id
 --        Interface functions for binding and re-binding names
 ------------------------------------------------------------------------
 
-bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
+bindToReg :: HasCallStack => NonVoid Id -> LambdaFormInfo -> FCode LocalReg
 -- Bind an Id to a fresh LocalReg
 bindToReg nvid@(NonVoid id) lf_info
   = do platform <- getPlatform
@@ -168,20 +176,20 @@ bindToReg nvid@(NonVoid id) lf_info
        addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
        return reg
 
-rebindToReg :: NonVoid Id -> FCode LocalReg
+rebindToReg :: HasCallStack => NonVoid Id -> FCode LocalReg
 -- Like bindToReg, but the Id is already in scope, so
 -- get its LF info from the envt
 rebindToReg nvid@(NonVoid id)
   = do  { info <- getCgIdInfo id
         ; bindToReg nvid (cg_lf info) }
 
-bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg :: HasCallStack => NonVoid Id -> FCode LocalReg
 bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
 
-bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
+bindArgsToRegs :: HasCallStack => [NonVoid Id] -> FCode [LocalReg]
 bindArgsToRegs args = mapM bindArgToReg args
 
-idToReg :: Platform -> NonVoid Id -> LocalReg
+idToReg :: HasCallStack => Platform -> NonVoid Id -> LocalReg
 -- Make a register from an Id, typically a function argument,
 -- free variable, or case binder
 --
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 6355b55427..dbf93023c5 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -56,6 +56,8 @@ import GHC.Utils.Panic.Plain
 import Control.Monad ( unless, void )
 import Control.Arrow ( first )
 import Data.List     ( partition )
+import GHC.Utils.Trace (pprTraceM)
+import GHC.Platform.Profile (Profile(profilePlatform))
 
 ------------------------------------------------------------------------
 --              cgExpr: the main function
@@ -153,12 +155,15 @@ cgLneBinds :: BlockId -> CgStgBinding -> FCode ()
 cgLneBinds join_id (StgNonRec bndr rhs)
   = do  { local_cc <- saveCurrentCostCentre
                 -- See Note [Saving the current cost centre]
+        ; pprTraceM "cgLneBinds" (ppr bndr)
         ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
         ; fcode
         ; addBindC info }
 
 cgLneBinds join_id (StgRec pairs)
   = do  { local_cc <- saveCurrentCostCentre
+        ; pprTraceM "cgLneBinds" (ppr $ map fst pairs)
+
         ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs
         ; let (infos, fcodes) = unzip r
         ; addBindsC infos
@@ -897,6 +902,7 @@ cgIdApp fun_id args = do
         lf_info     = cg_lf         fun_info
         n_args      = length args
         v_args      = length $ filter (isVoidTy . stgArgType) args
+    pprTraceM "fun_info" (ppr fun_id <+> pdoc (profilePlatform profile) fun_info)
     case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of
             -- A value in WHNF, so we can just return it.
         ReturnIt
diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs
index 5da6e6e5d9..3fff023d39 100644
--- a/compiler/GHC/Utils/Trace.hs
+++ b/compiler/GHC/Utils/Trace.hs
@@ -9,6 +9,7 @@ module GHC.Utils.Trace
   , warnPprTrace
   , pprTraceUserWarning
   , trace
+  , traceCallStackDoc
   )
 where
 
diff --git a/compiler/MachDeps.h b/compiler/MachDeps.h
new file mode 100644
index 0000000000..98a90814d9
--- /dev/null
+++ b/compiler/MachDeps.h
@@ -0,0 +1,119 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2002
+ *
+ * Definitions that characterise machine specific properties of basic
+ * types (C & Haskell) of a target platform.
+ *
+ * NB: Keep in sync with HsFFI.h and StgTypes.h.
+ * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Don't allow stage1 (cross-)compiler embed assumptions about target
+ * platform. When ghc-stage1 is being built by ghc-stage0 is should not
+ * refer to target defines. A few past examples:
+ *  - https://gitlab.haskell.org/ghc/ghc/issues/13491
+ *  - https://phabricator.haskell.org/D3122
+ *  - https://phabricator.haskell.org/D3405
+ *
+ * In those cases code change assumed target defines like SIZEOF_HSINT
+ * are applied to host platform, not target platform.
+ *
+ * So what should be used instead in GHC_STAGE=1?
+ *
+ * To get host's equivalent of SIZEOF_HSINT you can use Bits instances:
+ *    Data.Bits.finiteBitSize (0 :: Int)
+ *
+ * To get target's values it is preferred to use runtime target
+ * configuration from 'targetPlatform :: DynFlags -> Platform'
+ * record.
+ *
+ * Hence we hide these macros from GHC_STAGE=1
+ */
+
+/* Sizes of C types come from here... */
+#include "ghcautoconf.h"
+
+/* Sizes of Haskell types follow.  These sizes correspond to:
+ *   - the number of bytes in the primitive type (eg. Int#)
+ *   - the number of bytes in the external representation (eg. HsInt)
+ *   - the scale offset used by writeFooOffAddr#
+ *
+ * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1,
+ * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap.
+ */
+
+#define SIZEOF_HSCHAR           SIZEOF_WORD32
+#define ALIGNMENT_HSCHAR        ALIGNMENT_WORD32
+
+#define SIZEOF_HSINT            SIZEOF_VOID_P
+#define ALIGNMENT_HSINT         ALIGNMENT_VOID_P
+
+#define SIZEOF_HSWORD           SIZEOF_VOID_P
+#define ALIGNMENT_HSWORD        ALIGNMENT_VOID_P
+
+#define SIZEOF_HSDOUBLE         SIZEOF_DOUBLE
+#define ALIGNMENT_HSDOUBLE      ALIGNMENT_DOUBLE
+
+#define SIZEOF_HSFLOAT          SIZEOF_FLOAT
+#define ALIGNMENT_HSFLOAT       ALIGNMENT_FLOAT
+
+#define SIZEOF_HSPTR            SIZEOF_VOID_P
+#define ALIGNMENT_HSPTR         ALIGNMENT_VOID_P
+
+#define SIZEOF_HSFUNPTR         SIZEOF_VOID_P
+#define ALIGNMENT_HSFUNPTR      ALIGNMENT_VOID_P
+
+#define SIZEOF_HSSTABLEPTR      SIZEOF_VOID_P
+#define ALIGNMENT_HSSTABLEPTR   ALIGNMENT_VOID_P
+
+#define SIZEOF_INT8             SIZEOF_INT8_T
+#define ALIGNMENT_INT8          ALIGNMENT_INT8_T
+
+#define SIZEOF_WORD8            SIZEOF_UINT8_T
+#define ALIGNMENT_WORD8         ALIGNMENT_UINT8_T
+
+#define SIZEOF_INT16            SIZEOF_INT16_T
+#define ALIGNMENT_INT16         ALIGNMENT_INT16_T
+
+#define SIZEOF_WORD16           SIZEOF_UINT16_T
+#define ALIGNMENT_WORD16        ALIGNMENT_UINT16_T
+
+#define SIZEOF_INT32            SIZEOF_INT32_T
+#define ALIGNMENT_INT32         ALIGNMENT_INT32_T
+
+#define SIZEOF_WORD32           SIZEOF_UINT32_T
+#define ALIGNMENT_WORD32        ALIGNMENT_UINT32_T
+
+#define SIZEOF_INT64            SIZEOF_INT64_T
+#define ALIGNMENT_INT64         ALIGNMENT_INT64_T
+
+#define SIZEOF_WORD64           SIZEOF_UINT64_T
+#define ALIGNMENT_WORD64        ALIGNMENT_UINT64_T
+
+#if !defined(WORD_SIZE_IN_BITS)
+#if SIZEOF_HSWORD == 4
+#define WORD_SIZE_IN_BITS       32
+#define WORD_SIZE_IN_BITS_FLOAT 32.0
+#else
+#define WORD_SIZE_IN_BITS       64
+#define WORD_SIZE_IN_BITS_FLOAT 64.0
+#endif
+#endif
+
+#if !defined(TAG_BITS)
+#if SIZEOF_HSWORD == 4
+#define TAG_BITS                2
+#else
+#define TAG_BITS                3
+#endif
+#endif
+
+#define TAG_MASK ((1 << TAG_BITS) - 1)
+