[commit: ghc] wip/T14373: Implement pointer tagging for 'big' families #14373 (9e02458)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T14373
Link       : http://ghc.haskell.org/trac/ghc/changeset/9e02458022b4c24525c5f6e41e5d7b34309be424/ghc

>---------------------------------------------------------------

commit 9e02458022b4c24525c5f6e41e5d7b34309be424
Author: Gabor Greif <ggreif at gmail.com>
Date:   Fri Oct 20 15:45:37 2017 +0200

    Implement pointer tagging for 'big' families #14373
    
    Formerly we punted on these and evaluated constructors always
    got a tag of 1.
    
    We now cascade switches because we have to check the tag first
    and when it is MAX_PTR_TAG then get the precise tag from the info
    table and switch on that. The only technically tricky part is that the
    default case needs (logical) duplication. To do this we emit an extra
    label for it and branch to that from the second switch. This avoids
    duplicated codegen.


>---------------------------------------------------------------

9e02458022b4c24525c5f6e41e5d7b34309be424
 compiler/codeGen/StgCmmClosure.hs |  9 ++++--
 compiler/codeGen/StgCmmExpr.hs    | 61 +++++++++++++++++++++++++++++----------
 2 files changed, 53 insertions(+), 17 deletions(-)

diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 1da1f70..be2c206 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -354,9 +354,12 @@ type DynTag = Int       -- The tag on a *pointer*
 --    * big, otherwise.
 --
 -- Small families can have the constructor tag in the tag bits.
--- Big families only use the tag value 1 to represent evaluatedness.
+-- Big families only use the tag value 1..mAX_PTR_TAG to represent
+-- evaluatedness, the last one lumping together all overflowing ones.
 -- We don't have very many tag bits: for example, we have 2 bits on
 -- x86-32 and 3 bits on x86-64.
+--
+-- Also see Note [tagging big families]
 
 isSmallFamily :: DynFlags -> Int -> Bool
 isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
@@ -364,10 +367,12 @@ isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
 tagForCon :: DynFlags -> DataCon -> DynTag
 tagForCon dflags con
   | isSmallFamily dflags fam_size = con_tag
-  | otherwise                     = 1
+  | con_tag <= max_tag            = con_tag
+  | otherwise                     = max_tag
   where
     con_tag  = dataConTag con -- NB: 1-indexed
     fam_size = tyConFamilySize (dataConTyCon con)
+    max_tag = mAX_PTR_TAG dflags
 
 tagForArity :: DynFlags -> RepArity -> DynTag
 tagForArity dflags arity
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 3fcc935..a80de94 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -37,6 +37,7 @@ import Cmm
 import CmmInfo
 import CoreSyn
 import DataCon
+import DynFlags         ( mAX_PTR_TAG )
 import ForeignCall
 import Id
 import PrimOp
@@ -49,9 +50,10 @@ import Util
 import FastString
 import Outputable
 
-import Control.Monad (unless,void)
-import Control.Arrow (first)
+import Control.Monad ( unless, void )
+import Control.Arrow ( first )
 import Data.Function ( on )
+import Data.List     ( partition )
 
 ------------------------------------------------------------------------
 --              cgExpr: the main function
@@ -607,21 +609,36 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
 
         ; let fam_sz   = tyConFamilySize tycon
               bndr_reg = CmmLocal (idToReg dflags bndr)
+              tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
+              branches' = [(tag+1,branch) | (tag,branch) <- branches]
+              maxpt = mAX_PTR_TAG dflags
+              (ptr, info) = partition ((< maxpt) . fst) branches'
+              small = isSmallFamily dflags fam_sz
 
                     -- Is the constructor tag in the node reg?
-        ; if isSmallFamily dflags fam_sz
-          then do
-                let   -- Yes, bndr_reg has constr. tag in ls bits
-                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
-                   branches' = [(tag+1,branch) | (tag,branch) <- branches]
-                emitSwitch tag_expr branches' mb_deflt 1 fam_sz
-
-           else -- No, get tag from info table
-                let -- Note that ptr _always_ has tag 1
-                    -- when the family size is big enough
-                    untagged_ptr = cmmRegOffB bndr_reg (-1)
-                    tag_expr = getConstrTag dflags (untagged_ptr)
-                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
+                    -- See Note [tagging big families]
+        ; if small || null info
+           then -- Yes, bndr_reg has constr. tag in ls bits
+               emitSwitch tag_expr branches' mb_deflt 1 (if small then fam_sz else maxpt)
+
+           else -- No, get exact tag from info table when mAX_PTR_TAG
+              do
+                infos_lbl <- newBlockId -- branch destination for info pointer lookup
+                infos_scp <- getTickScope
+
+                let catchall = (maxpt, (mkBranch infos_lbl, infos_scp))
+                    prelabel (Just (stmts, scp)) =
+                      do lbl <- newBlockId
+                         return (Just (mkLabel lbl scp <*> stmts, scp), Just (mkBranch lbl, scp))
+                    prelabel _ = return (Nothing, Nothing)
+
+                (mb_deflt, mb_branch) <- prelabel mb_deflt
+                emitSwitch tag_expr (catchall : ptr) mb_deflt 1 maxpt
+                emitLabel infos_lbl
+                let untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)
+                    tag_expr = getConstrTag dflags untagged_ptr
+                    info0 = (\(tag,branch)->(tag-1,branch)) <$> info
+                emitSwitch tag_expr info0 mb_branch (maxpt - 1) (fam_sz - 1)
 
         ; return AssignedDirectly }
 
@@ -649,6 +666,20 @@ cgAlts _ _ _ _ = panic "cgAlts"
 --   x = R1
 --   goto L1
 
+
+-- Note [tagging big families]
+--
+-- Previousy, only the small constructor families were tagged.
+-- This penalized greater union which overflow the tag space
+-- of TAG_BITS (i.e. 3 on 32 resp. 7 constructors on 64 bit).
+-- But there is a clever way of combining pointer and info-table
+-- tagging. We now use 1..{2,6} as pointer-resident tags while
+-- {3,7} signifies we have to fall back and get the tag from the
+-- info-table.
+--
+-- Also see Note [Data constructor dynamic tags]
+
+
 -------------------
 cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [StgAlt]
              -> FCode ( Maybe CmmAGraphScoped