Merge branch 'newcg' of /home/simonmar/code-all/work/ghc-newcg into newcg
authorSimon Marlow <marlowsd@gmail.com>
Sun, 19 Feb 2012 13:04:37 +0000 (13:04 +0000)
committerSimon Marlow <marlowsd@gmail.com>
Sun, 19 Feb 2012 13:04:37 +0000 (13:04 +0000)
16 files changed:
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/SMRep.lhs
compiler/cmm/cmm-notes
compiler/codeGen/CgInfoTbls.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmUtils.hs
compiler/nativeGen/AsmCodeGen.lhs

index d15d408..43ff2b0 100644 (file)
@@ -18,8 +18,7 @@ module CmmBuildInfoTables
     , TopSRT, emptySRT, srtToData
     , bundleCAFs
     , lowerSafeForeignCalls
-    , cafTransfers
-    , mkLiveness )
+    , cafTransfers )
 where
 
 #include "HsVersions.h"
index 2442bf0..9a382c0 100644 (file)
@@ -24,6 +24,7 @@ import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Control.Monad.Fix
 import Data.Array as Array
+import Data.Bits
 
 #include "HsVersions.h"
 
@@ -183,20 +184,59 @@ layout procpoints liveness entry entry_args final_stackmaps final_hwm blocks
        let hwm'    = maximum (acc_hwm : map sm_sp (mapElems out))
            middle2 = maybeAddSpAdj sp_off $ foldl blockSnoc middle1 saves
     
+           area_off = getAreaOff final_stackmaps
+
            -- manifest Sp: turn all CmmStackSlots into actual loads
-           fiddle_middle = mapExpDeep (areaToSp sp0 sp_high final_stackmaps)
-           fiddle_last   = mapExpDeep (areaToSp (sp0 - sp_off) sp_high
-                                                final_stackmaps)
-    
+           adj_middle = mapExpDeep (areaToSp sp0            sp_high area_off)
+           adj_last   = optStackCheck .
+                        mapExpDeep (areaToSp (sp0 - sp_off) sp_high area_off)
+
+           middle3 = blockFromList $
+                     map adj_middle $
+                     elimStackStores stack0 final_stackmaps area_off $
+                     blockToList middle2
+
+           newblock = blockJoin entry0 middle3 (adj_last last1)
+
+           fixup_blocks' = map (blockMapNodes3 (id, adj_middle, id)) fixup_blocks
+
            stackmaps' = mapUnion acc_stackmaps out
-           newblock   = blockJoin entry0 middle2 last1
-           newblock'  = blockMapNodes3 (id, fiddle_middle, fiddle_last) newblock
-           fixup_blocks' = map (blockMapNodes3 (id, fiddle_middle, id))
-                               fixup_blocks
-    
+
        pprTrace "layout(out)" (ppr out) $ return ()
     
-       go bs stackmaps' hwm' (newblock' : fixup_blocks' ++ acc_blocks)
+       go bs stackmaps' hwm' (newblock : fixup_blocks' ++ acc_blocks)
+
+
+-- | Eliminate stores of the form
+--
+--    Sp[area+n] = r
+--
+-- when we know that r is already in the same slot as Sp[area+n].  We
+-- could do this in a later optimisation pass, but that would involve
+-- a separate analysis and we already have the information to hand
+-- here.  It helps clean up some extra stack stores in common cases.
+--
+-- Note that we may have to modify the StackMap as we walk through the
+-- code using procMiddle, since an assignment to a variable in the
+-- StackMap will invalidate its mapping there.
+--
+elimStackStores :: StackMap
+                -> BlockEnv StackMap
+                -> (Area -> ByteOff)
+                -> [CmmNode O O]
+                -> [CmmNode O O]
+elimStackStores stackmap stackmaps area_off nodes
+  = go stackmap nodes
+  where
+    go _stackmap [] = []
+    go stackmap (n:ns)
+     = case n of
+         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
+            | Just (_,off) <- lookupUFM (sm_regs stackmap) r
+            , area_off area + m == off
+            -> pprTrace "eliminated a node!" (ppr r) $ go stackmap ns
+         _otherwise
+            -> n : go (procMiddle stackmaps n stackmap) ns
 
 
 -- This doesn't seem right somehow.  We need to find out whether this
@@ -234,7 +274,7 @@ maybeAddSpAdj sp_off block
 procMiddle :: BlockEnv StackMap -> CmmNode e x -> StackMap -> StackMap
 procMiddle stackmaps node sm
   = case node of
-     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) t)
+     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
        -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
         where loc = getStackLoc area off stackmaps
      CmmAssign (CmmLocal r) _other
@@ -275,11 +315,31 @@ handleLastNode procpoints liveness cont_info stackmaps
       return ([], mapEmpty, sp_off, last, [])
 
     --  At each CmmCall with a continuation:
-    CmmCall{ cml_cont = Just cont_lbl, .. }
+    CmmCall{ cml_cont = Just cont_lbl, .. } ->
+       lastCall cont_lbl cml_args cml_ret_args cml_ret_off
+
+    CmmForeignCall{ succ = cont_lbl, .. } ->
+       lastCall cont_lbl 0{-no args-} 0{-no results-} (sm_ret_off stack0)
+
+    CmmBranch{..}     ->  handleProcPoints
+    CmmCondBranch{..} ->  handleProcPoints
+    CmmSwitch{..}     ->  handleProcPoints
+
+  where
+     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
+              -> UniqSM
+                      ( [CmmNode O O]
+                      , BlockEnv StackMap
+                      , ByteOff
+                      , CmmNode O C
+                      , [CmmBlock]
+                      )
+
+     lastCall cont_lbl cml_args cml_ret_args cml_ret_off
       -- If we have already seen this continuation before, then
       -- we just have to make the stack look the same:
       | Just cont_stack <- mapLookup cont_lbl stackmaps
-      ->
+      =
          return ( fixupStack stack0 cont_stack
                 , stackmaps
                 , sp0 - sm_sp cont_stack
@@ -288,7 +348,7 @@ handleLastNode procpoints liveness cont_info stackmaps
 
       -- a continuation we haven't seen before:
       -- allocate the stack frame for it.
-      | otherwise -> do
+      | otherwise = do
 
       -- get the set of LocalRegs live in the continuation
       let target_live = mapFindWithDefault Set.empty cont_lbl
@@ -328,11 +388,7 @@ handleLastNode procpoints liveness cont_info stackmaps
              , [] -- no new blocks
              )
 
-    CmmBranch{..}     ->  handleProcPoints
-    CmmCondBranch{..} ->  handleProcPoints
-    CmmSwitch{..}     ->  handleProcPoints
 
-  where
      handleProcPoints :: UniqSM ( [CmmNode O O]
                                 , BlockEnv StackMap
                                 , ByteOff
@@ -350,7 +406,7 @@ handleLastNode procpoints liveness cont_info stackmaps
                  , mapSuccessors fix_lbl last
                  , concat [ blk | (_,_,_,blk) <- pps ] )
 
-     -- For each proc point that is a successor of this block, we need to
+     -- For each proc point that is a successor of this block
      --   (a) if the proc point already has a stackmap, we need to
      --       shuffle the current stack to make it look the same.
      --       We have to insert a new block to make this happen.
@@ -384,10 +440,6 @@ handleLastNode procpoints liveness cont_info stackmaps
            return (l, tmp_lbl, stack3, [block])
 
 
-     passthrough :: BlockEnv StackMap
-     passthrough = mapFromList (zip (successors last) (repeat stack0))
-
-
 -- | create a sequence of assignments to establish the new StackMap,
 -- given the old StackMap.
 fixupStack :: StackMap -> StackMap -> [CmmNode O O]
@@ -414,29 +466,51 @@ OLD area.
 SpArgs(L) is the size of the young area for L, i.e. the number of
 arguments.
 
- - in block L, each reference to (OldArea[N]) turns into
+ - in block L, each reference to [old + N] turns into
    [Sp + Sp(L) - N]
 
- - in block L, each reference to (Young(L')[N]) turns into
+ - in block L, each reference to [young(L') + N] turns into
    [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]
 
  - be careful with the last node of each block: Sp has already been adjusted
    to be Sp + Sp(L) - Sp(L')
 -}
 
-areaToSp :: ByteOff -> ByteOff -> BlockEnv StackMap -> CmmExpr -> CmmExpr
-areaToSp sp_old _sp_hwm stackmaps (CmmStackSlot area n) =
-  cmmOffset (CmmReg spReg) (sp_old - area_off - n)
-  where
-    area_off = case area of
-                 Old -> 0
-                 Young l ->
-                    case mapLookup l stackmaps of
-                       Just sm -> sm_sp sm - sm_args sm
-                       Nothing -> pprPanic "areaToSp(2)" (ppr l)
+areaToSp :: ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+areaToSp sp_old _sp_hwm area_off (CmmStackSlot area n) =
+  cmmOffset (CmmReg spReg) (sp_old - area_off area - n)
 areaToSp _ sp_hwm _ (CmmLit CmmHighStackMark) = CmmLit (mkIntCLit sp_hwm)
+areaToSp _ _ _ (CmmMachOp (MO_U_Lt _)  -- Note [null stack check]
+                      [CmmMachOp (MO_Sub _)
+                              [ CmmReg (CmmGlobal Sp)
+                              , CmmLit (CmmInt 0 _)],
+                       CmmReg (CmmGlobal SpLim)]) = CmmLit (CmmInt 0 wordWidth)
 areaToSp _ _ _ other = other
 
+-- Note [null stack check]
+--
+-- If the high-water Sp is zero, then we end up with
+--
+--   if (Sp - 0 < SpLim) then .. else ..
+--
+-- and possibly some dead code for the failure case.  Optimising this
+-- away depends on knowing that SpLim <= Sp, so it is really the job
+-- of the stack layout algorithm, hence we do it now.  This is also
+-- convenient because control-flow optimisation later will drop the
+-- dead code.
+
+optStackCheck :: CmmNode O C -> CmmNode O C
+optStackCheck n = -- Note [null stack check]
+ case n of
+   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false -> CmmBranch false
+   other -> other
+
+getAreaOff :: BlockEnv StackMap -> (Area -> StackLoc)
+getAreaOff _ Old = 0
+getAreaOff stackmaps (Young l) =
+  case mapLookup l stackmaps of
+    Just sm -> sm_sp sm - sm_args sm
+    Nothing -> pprPanic "getAreaOff" (ppr l)
 
 -- -----------------------------------------------------------------------------
 -- Saving live registers
@@ -495,7 +569,7 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
        select_save :: [LocalReg] -> [StackSlot]
                    -> Maybe ([StackSlot], LocalReg, [LocalReg])
        select_save regs stack = go regs []
-         where go []     no_fit = Nothing
+         where go []     _no_fit = Nothing
                go (r:rs) no_fit
                  | Just rest <- dropEmpty words stack
                  = Just (replicate words Occupied ++ rest, r, rs++no_fit)
@@ -514,16 +588,14 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
               push r (n, assigs, regs)
                 = (n', assig : assigs, (r,(r,n')) : regs)
                 where
-                  w  = typeWidth (localRegType r)
-                  n' = n + widthInBytes w
+                  n' = n + localRegBytes r
                   assig = CmmStore (CmmStackSlot Old n')
                                    (CmmReg (CmmLocal r))
 
        trim_sp
           | not (null push_regs) = push_sp
           | otherwise
-          = case break notEmpty save_stack of
-              (empties, rest) -> n `plusW` (- length empties)
+          = n `plusW` (- length (takeWhile isEmpty save_stack))
 
        final_regs = regs1 `addListToUFM` push_regs
                           `addListToUFM` save_regs
@@ -532,10 +604,11 @@ allocate ret_off live stackmap@StackMap{ sm_sp = sp0
   -- XXX should be an assert
    if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
 
+   if (trim_sp .&. (wORD_SIZE - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+
    ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
    , push_assigs ++ save_assigs )
 
-
 -- -----------------------------------------------------------------------------
 -- Update info tables to include stack liveness
 
@@ -555,6 +628,9 @@ setInfoTableStackMap stackmaps
           Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl)
           Just sm -> stackMapToLiveness sm
 
+setInfoTableStackMap _ d = d
+
+
 stackMapToLiveness :: StackMap -> Liveness
 stackMapToLiveness StackMap{..} =
    reverse $ Array.elems $
@@ -573,17 +649,14 @@ plusW b w = b + w * wORD_SIZE
 dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
 dropEmpty 0 ss           = Just ss
 dropEmpty n (Empty : ss) = dropEmpty (n-1) ss
-dropEmpty n _            = Nothing
-
-pushEmpty :: ByteOff -> [StackSlot] -> [StackSlot]
-pushEmpty n stack = replicate (toWords n) Empty ++ stack
+dropEmpty _ _            = Nothing
 
-notEmpty :: StackSlot -> Bool
-notEmpty Empty = False
-notEmpty _ = True
+isEmpty :: StackSlot -> Bool
+isEmpty Empty = True
+isEmpty _ = False
 
 localRegBytes :: LocalReg -> ByteOff
-localRegBytes r = widthInBytes (typeWidth (localRegType r))
+localRegBytes r = roundUpToWords (widthInBytes (typeWidth (localRegType r)))
 
 localRegWords :: LocalReg -> WordOff
 localRegWords = toWords . localRegBytes
index ae715a9..105453e 100644 (file)
@@ -158,22 +158,13 @@ cmmMiniInlineStmts platform uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr
   | Nothing <- lookupUFM uses u
   = cmmMiniInlineStmts platform uses stmts
 
-        -- used (literal): try to inline at all the use sites
-  | Just n <- lookupUFM uses u, isLit expr
-  =
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
-     case lookForInlineLit u expr stmts of
-         (m, stmts')
-             | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts'
-             | otherwise ->
-                 stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts'
-
-        -- used (foldable to literal): try to inline at all the use sites
+        -- used (foldable to small thing): try to inline at all the use sites
   | Just n <- lookupUFM uses u,
-    e@(CmmLit _) <- wrapRecExp foldExp expr
+    e <- wrapRecExp foldExp expr,
+    isTiny e
   =
      ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
-     case lookForInlineLit u e stmts of
+     case lookForInlineMany u e stmts of
          (m, stmts')
              | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts'
              | otherwise ->
@@ -186,6 +177,10 @@ cmmMiniInlineStmts platform uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr
      ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
      cmmMiniInlineStmts platform uses stmts'
  where
+  isTiny (CmmLit _) = True
+  isTiny (CmmReg _) = True
+  isTiny _ = False
+
   foldExp (CmmMachOp op args) = cmmMachOpFold platform op args
   foldExp e = e
 
@@ -198,26 +193,25 @@ cmmMiniInlineStmts platform uses (stmt:stmts)
 -- register, and a list of statements.  Inlines the expression at all
 -- use sites of the register.  Returns the number of substituations
 -- made and the, possibly modified, list of statements.
-lookForInlineLit :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt])
-lookForInlineLit _ _ [] = (0, [])
-lookForInlineLit u expr stmts@(stmt : rest)
+lookForInlineMany :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt])
+lookForInlineMany u expr stmts = lookForInlineMany' u expr regset stmts
+    where regset = foldRegsUsed extendRegSet emptyRegSet expr
+
+lookForInlineMany' :: Unique -> CmmExpr -> RegSet -> [CmmStmt] -> (Int, [CmmStmt])
+lookForInlineMany' _ _ _ [] = (0, [])
+lookForInlineMany' u expr regset stmts@(stmt : rest)
   | Just n <- lookupUFM (countUses stmt) u
-  = case lookForInlineLit u expr rest of
+  = case lookForInlineMany' u expr regset rest of
       (m, stmts) -> let z = n + m
                     in z `seq` (z, inlineStmt u expr stmt : stmts)
 
-  | ok_to_skip
-  = case lookForInlineLit u expr rest of
+  | okToSkip stmt u expr regset
+  = case lookForInlineMany' u expr regset rest of
       (n, stmts) -> (n, stmt : stmts)
 
   | otherwise
   = (0, stmts)
-  where
-    -- We skip over assignments to registers, unless the register
-    -- being assigned to is the one we're inlining.
-    ok_to_skip = case stmt of
-        CmmAssign (CmmLocal (LocalReg u' _)) _ | u' == u -> False
-        _other -> True
+
 
 lookForInline :: Unique -> CmmExpr -> [CmmStmt] -> Maybe [CmmStmt]
 lookForInline u expr stmts = lookForInline' u expr regset stmts
@@ -229,7 +223,7 @@ lookForInline' u expr regset (stmt : rest)
   | Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline
   = Just (inlineStmt u expr stmt : rest)
 
-  | ok_to_skip
+  | okToSkip stmt u expr regset
   = case lookForInline' u expr regset rest of
            Nothing    -> Nothing
            Just stmts -> Just (stmt:stmts)
@@ -247,21 +241,26 @@ lookForInline' u expr regset (stmt : rest)
                      CmmCall{} -> hasNoGlobalRegs expr
                      _ -> True
 
-   -- Expressions aren't side-effecting.  Temporaries may or may not
-   -- be single-assignment depending on the source (the old code
-   -- generator creates single-assignment code, but hand-written Cmm
-   -- and Cmm from the new code generator is not single-assignment.)
-   -- So we do an extra check to make sure that the register being
-   -- changed is not one we were relying on.  I don't know how much of a
-   -- performance hit this is (we have to create a regset for every
-   -- instruction.) -- EZY
-    ok_to_skip = case stmt of
-                 CmmNop -> True
-                 CmmComment{} -> True
-                 CmmAssign (CmmLocal r@(LocalReg u' _)) _rhs | u' /= u && not (r `elemRegSet` regset) -> True
-                 CmmAssign g@(CmmGlobal _) _rhs -> not (g `regUsedIn` expr)
-                 _other -> False
-
+-- Expressions aren't side-effecting.  Temporaries may or may not
+-- be single-assignment depending on the source (the old code
+-- generator creates single-assignment code, but hand-written Cmm
+-- and Cmm from the new code generator is not single-assignment.)
+-- So we do an extra check to make sure that the register being
+-- changed is not one we were relying on.  I don't know how much of a
+-- performance hit this is (we have to create a regset for every
+-- instruction.) -- EZY
+okToSkip stmt u expr regset
+   = case stmt of
+         CmmNop -> True
+         CmmComment{} -> True
+         CmmAssign (CmmLocal r@(LocalReg u' _)) _rhs | u' /= u && not (r `elemRegSet` regset) -> True
+         CmmAssign g@(CmmGlobal _) _rhs -> not (g `regUsedIn` expr)
+         CmmStore _ _ -> not_a_load expr
+         _other -> False
+  where
+    not_a_load (CmmMachOp _ args) = all not_a_load args
+    not_a_load (CmmLoad _ _) = False
+    not_a_load _ = True
 
 inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
 inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
index 395da3c..5cecb57 100644 (file)
@@ -60,7 +60,7 @@ module CmmUtils(
         -- * Operations that probably don't belong here
         modifyGraph,
 
-        lastNode, replaceLastNode, insertBetween,
+        lastNode, replaceLastNode,
         ofBlockMap, toBlockMap, insertBlock,
         ofBlockList, toBlockList, bodyToBlockList,
         foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
@@ -442,49 +442,6 @@ foldGraphBlocks k z g = mapFold k z $ toBlockMap g
 postorderDfs :: CmmGraph -> [CmmBlock]
 postorderDfs g = {-# SCC "postorderDfs" #-} postorder_dfs_from (toBlockMap g) (g_entry g)
 
-----------------------------------------------------------------------
------ Splicing between blocks
--- Given a middle node, a block, and a successor BlockId,
--- we can insert the middle node between the block and the successor.
--- We return the updated block and a list of new blocks that must be added
--- to the graph.
--- The semantics is a bit tricky. We consider cases on the last node:
--- o For a branch, we can just insert before the branch,
---   but sometimes the optimizer does better if we actually insert
---   a fresh basic block, enabling some common blockification.
--- o For a conditional branch, switch statement, or call, we must insert
---   a new basic block.
--- o For a jump or return, this operation is impossible.
-
-insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock])
-insertBetween b ms succId = insert $ lastNode b
-  where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock])
-        insert (CmmBranch bid) =
-          if bid == succId then
-            do (bid', bs) <- newBlocks
-               return (replaceLastNode b (CmmBranch bid'), bs)
-          else panic "tried invalid block insertBetween"
-        insert (CmmCondBranch c t f) =
-          do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
-             (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
-             return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs)
-        insert (CmmSwitch e ks) =
-          do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
-             return (replaceLastNode b (CmmSwitch e ids), join bs)
-        insert (CmmCall {}) =
-          panic "unimp: insertBetween after a call -- probably not a good idea"
-        insert (CmmForeignCall {}) =
-          panic "unimp: insertBetween after a foreign call -- probably not a good idea"
-
-        newBlocks :: MonadUnique m => m (BlockId, [CmmBlock])
-        newBlocks = do id <- liftM mkBlockId $ getUniqueM
-                       return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))])
-        mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock])
-        mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks
-                               else return (Just k, [])
-        mbNewBlocks Nothing  = return (Nothing, [])
-        fstJust (id, bs) = (Just id, bs)
-
 -------------------------------------------------
 -- Running dataflow analysis and/or rewrites
 
index ce30799..8b3308e 100644 (file)
@@ -21,6 +21,7 @@ module SMRep (
        StgWord, StgHalfWord, 
        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
        WordOff, ByteOff,
+        roundUpToWords,
 
         -- * Closure repesentation
         SMRep(..),     -- CmmInfo sees the rep; no one else does
@@ -57,6 +58,7 @@ import FastString
 
 import Data.Char( ord )
 import Data.Word
+import Data.Bits
 \end{code}
 
 
@@ -69,6 +71,9 @@ import Data.Word
 \begin{code}
 type WordOff = Int     -- Word offset, or word count
 type ByteOff = Int     -- Byte offset, or byte count
+
+roundUpToWords :: ByteOff -> ByteOff
+roundUpToWords n = (n + (wORD_SIZE - 1)) .&. (complement (wORD_SIZE - 1))
 \end{code}
 
 StgWord is a type representing an StgWord on the target platform.
@@ -93,6 +98,7 @@ hALF_WORD_SIZE_IN_BITS = 32
 #endif
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}
index 9df5cb0..0e6a234 100644 (file)
@@ -24,27 +24,10 @@ More notes (June 11)
 * Check in ClosureInfo:\r
      -- NB: Results here should line up with the results of SMRep.rtsClosureType\r
 \r
-* Possible refactoring: Nuke AGraph in favour of \r
-      mkIfThenElse :: Expr -> Graph -> Graph -> FCode Graph\r
-  or even\r
-      mkIfThenElse :: HasUniques m => Expr -> Graph -> Graph -> m Graph\r
-  (Remmber that the .cmm file parser must use this function)\r
-\r
-  or parameterise FCode over its envt; the CgState part seem useful for both\r
-\r
 * "Remove redundant reloads" in CmmSpillReload should be redundant; since\r
   insertLateReloads is now gone, every reload is reloading a live variable.\r
   Test and nuke.\r
 \r
-* Stack layout is very like register assignment: find non-conflicting assigments.\r
-  In particular we can use colouring or linear scan (etc).\r
-\r
-  We'd fine-grain interference (on a word by word basis) to get maximum overlap.\r
-  But that may make very big interference graphs.  So linear scan might be\r
-  more attactive.\r
-\r
-  NB: linear scan does on-the-fly live range splitting.\r
-\r
 * When stubbing dead slots be careful not to write into an area that\r
   overlaps with an area that's in use.  So stubbing needs to *follow* \r
   stack layout.\r
index ee5fb59..f98d579 100644 (file)
@@ -36,7 +36,7 @@ import CgBindery
 import CgCallConv
 import CgUtils
 import CgMonad
-import CmmBuildInfoTables
+import CmmUtils
 
 import OldCmm
 import CLabel
index 0222299..7dbc995 100644 (file)
@@ -76,16 +76,16 @@ cgTopRhsClosure :: Id
 cgTopRhsClosure id ccs _ upd_flag srt args body = do
   {    -- LAY OUT THE OBJECT
     let name = idName id
-  ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
-  ; srt_info <- getSRTInfo srt
+  ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
+  ; has_srt <- getSRTInfo srt
   ; mod_name <- getModuleName
   ; let descr         = closureDescription mod_name name
-       closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
+        closure_info  = mkClosureInfo True id lf_info 0 0 descr
        closure_label = mkLocalClosureLabel name (idCafInfo id)
        cg_id_info    = litIdInfo id lf_info (CmmLabel closure_label)
         caffy         = idCafInfo id
         info_tbl      = mkCmmInfo closure_info -- XXX short-cut
-        closure_rep   = mkStaticClosureFields info_tbl ccs caffy []
+        closure_rep   = mkStaticClosureFields info_tbl ccs caffy has_srt []
 
         -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
   ; emitDataLits closure_label closure_rep
@@ -161,8 +161,8 @@ cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
 cgRhs name (StgRhsCon cc con args)
   = buildDynCon name cc con args
 
-cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
-  = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
+cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
+  = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag args body
 
 ------------------------------------------------------------------------
 --             Non-constructor right hand sides
@@ -170,7 +170,7 @@ cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
 
 mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
             -> [NonVoid Id]                    -- Free vars
-            -> UpdateFlag -> SRT
+             -> UpdateFlag
             -> [Id]                            -- Args
             -> StgExpr
             -> FCode (CgIdInfo, CmmAGraph)
@@ -214,8 +214,7 @@ for semi-obvious reasons.
 mkRhsClosure   bndr cc bi
                [NonVoid the_fv]                -- Just one free var
                upd_flag                -- Updatable thunk
-               _srt
-               []                      -- A thunk
+                []                      -- A thunk
                body@(StgCase (StgApp scrutinee [{-no args-}])
                      _ _ _ _   -- ignore uniq, etc.
                      (AlgAlt _)
@@ -246,8 +245,7 @@ mkRhsClosure        bndr cc bi
 mkRhsClosure    bndr cc bi
                fvs
                upd_flag
-               _srt
-               []                      -- No args; a thunk
+                []                      -- No args; a thunk
                body@(StgApp fun_id args)
 
   | args `lengthIs` (arity-1)
@@ -268,7 +266,7 @@ mkRhsClosure    bndr cc bi
        arity   = length fvs
 
 ---------- Default case ------------------
-mkRhsClosure bndr cc _ fvs upd_flag srt args body
+mkRhsClosure bndr cc _ fvs upd_flag args body
   = do {       -- LAY OUT THE OBJECT
        -- If the binder is itself a free variable, then don't store
        -- it in the closure.  Instead, just bind it to Node on entry.
@@ -287,8 +285,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
        -- MAKE CLOSURE INFO FOR THIS CLOSURE
        ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
        ; mod_name <- getModuleName
-       ; c_srt <- getSRTInfo srt
-       ; let   name  = idName bndr
+        ; let   name  = idName bndr
                descr = closureDescription mod_name name
                fv_details :: [(NonVoid Id, VirtualHpOffset)]
                (tot_wds, ptr_wds, fv_details)
@@ -296,7 +293,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body
                                       (addIdReps (map stripNV reduced_fvs))
                closure_info = mkClosureInfo False      -- Not static
                                             bndr lf_info tot_wds ptr_wds
-                                            c_srt descr
+                                             descr
 
        -- BUILD ITS INFO TABLE AND CODE
        ; forkClosureBody $
@@ -342,8 +339,7 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
        descr = closureDescription mod_name (idName bndr)
        closure_info = mkClosureInfo False      -- Not static
                                     bndr lf_info tot_wds ptr_wds
-                                    NoC_SRT    -- No SRT for a std-form closure
-                                    descr
+                                     descr
 
 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
   ; let use_cc = curCCS; blame_cc = curCCS
index 5c0741a..487c94d 100644 (file)
@@ -650,7 +650,6 @@ data ClosureInfo
           -- the rest is just an unpacked CmmInfoTable.
         closureInfoLabel :: !CLabel,
         closureSMRep     :: !SMRep,          -- representation used by storage mgr
-        closureSRT       :: !C_SRT,          -- What SRT applies to this closure
         closureProf      :: !ProfilingInfo
     }
 
@@ -660,7 +659,7 @@ mkCmmInfo ClosureInfo {..}
   = CmmInfoTable { cit_lbl  = closureInfoLabel
                  , cit_rep  = closureSMRep
                  , cit_prof = closureProf
-                 , cit_srt  = closureSRT }
+                 , cit_srt  = NoC_SRT }
 
 
 --------------------------------------
@@ -671,16 +670,14 @@ mkClosureInfo :: Bool             -- Is static
              -> Id
              -> LambdaFormInfo 
              -> Int -> Int     -- Total and pointer words
-             -> C_SRT
-             -> String         -- String descriptor
+              -> String         -- String descriptor
              -> ClosureInfo
-mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info val_descr
+mkClosureInfo is_static id lf_info tot_wds ptr_wds val_descr
   = ClosureInfo { closureName      = name,
                   closureLFInfo    = lf_info,
-                  closureInfoLabel = info_lbl,
-                  closureSMRep     = sm_rep,    -- These four fields are a
-                  closureSRT       = srt_info,  --        CmmInfoTable
-                  closureProf      = prof }     -- ---
+                  closureInfoLabel = info_lbl,  -- These three fields are
+                  closureSMRep     = sm_rep,    -- (almost) an info table
+                  closureProf      = prof }     -- (we don't have an SRT yet)
   where
     name       = idName id
     sm_rep     = mkHeapRep is_static ptr_wds nonptr_wds (lfClosureType lf_info)
@@ -906,15 +903,21 @@ cafBlackHoleInfoTable
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
-staticClosureNeedsLink :: CmmInfoTable -> Bool
+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
 --     a) it has an SRT
 --     b) it's a constructor with one or more pointer fields
 -- In case (b), the constructor's fields themselves play the role
 -- of the SRT.
-staticClosureNeedsLink info_tbl@CmmInfoTable{ cit_rep = smrep }
+--
+-- At this point, the cit_srt field has not been calculated (that
+-- happens right at the end of the Cmm pipeline), but we do have the
+-- VarSet of CAFs that CoreToStg attached, and if that is empty there
+-- will definitely not be an SRT.
+--
+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
   | isConRep smrep         = not (isStaticNoCafCon smrep)
-  | otherwise              = needsSRT (cit_srt info_tbl)
-staticClosureNeedsLink _ = False
+  | otherwise              = has_srt -- needsSRT (cit_srt info_tbl)
+staticClosureNeedsLink _ = False
 
index e17ac4f..1a40a42 100644 (file)
@@ -92,6 +92,7 @@ cgTopRhsCon id con args
                              info_tbl
                              dontCareCCS                -- Because it's static data
                              caffy                      -- Has CAF refs
+                             False                      -- no SRT
                              payload
 
                 -- BUILD THE OBJECT
index fe41de8..ccc9e6b 100644 (file)
@@ -284,15 +284,63 @@ data GcPlan
                        -- of the case alternative(s) into the upstream check
 
 -------------------------------------
--- See Note [case on Bool]
 cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode ()
+
+cgCase (StgOpApp (StgPrimOp op) args _) bndr _srt (AlgAlt tycon) alts
+  | isEnumerationTyCon tycon -- Note [case on bool]
+  = do { tag_expr <- do_enum_primop op args
+
+       -- If the binder is not dead, convert the tag to a constructor
+       -- and assign it.
+       ; when (not (isDeadBinder bndr)) $ do
+            { tmp_reg <- bindArgToReg (NonVoid bndr)
+            ; emitAssign (CmmLocal tmp_reg)
+                         (tagToClosure tycon tag_expr) }
+
+       ; (mb_deflt, branches) <- cgAlgAltRhss NoGcInAlts (NonVoid bndr) alts
+       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)
+       }
+  where
+    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr
+    do_enum_primop TagToEnumOp [arg]  -- No code!
+      = getArgAmode (NonVoid arg)
+    do_enum_primop primop args
+      = do tmp <- newTemp bWord
+           cgPrimOp [tmp] primop args
+           return (CmmReg (CmmLocal tmp))
+
 {-
-cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
-  | isBoolTy (idType bndr)
-  , isDeadBndr bndr
-  = 
+Note [case on bool]
+
+This special case handles code like
+
+  case a <# b of
+    True ->
+    False ->
+
+If we let the ordinary case code handle it, we'll get something like
+
+ tmp1 = a < b
+ tmp2 = Bool_closure_tbl[tmp1]
+ if (tmp2 & 7 != 0) then ... // normal tagged case
+
+but this junk won't optimise away.  What we really want is just an
+inline comparison:
+
+ if (a < b) then ...
+
+So we add a special case to generate
+
+ tmp1 = a < b
+ if (tmp1 == 0) then ...
+
+and later optimisations will further improve this.
+
+We should really change all these primops to return Int# instead, that
+would make this special case go away.
 -}
 
+
   -- Note [ticket #3132]: we might be looking at a case of a lifted Id
   -- that was cast to an unlifted type.  The Id will always be bottom,
   -- but we don't want the code generator to fall over here.  If we
@@ -439,17 +487,10 @@ cgAlts gc_plan bndr (PrimAlt _) alts
         ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt }
 
 cgAlts gc_plan bndr (AlgAlt tycon) alts
-  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
-       
+  = do  { (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts
+
        ; let fam_sz   = tyConFamilySize tycon
              bndr_reg = CmmLocal (idToReg bndr)
-             mb_deflt = case tagged_cmms of
-                          ((DEFAULT,rhs) : _) -> Just rhs
-                          _other              -> Nothing
-               -- DEFAULT is always first, if present
-
-             branches = [ (dataConTagZ con, cmm) 
-                        | (DataAlt con, cmm) <- tagged_cmms ]
 
                     -- Is the constructor tag in the node reg?
         ; if isSmallFamily fam_sz
@@ -470,6 +511,27 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts
 cgAlts _ _ _ _ = panic "cgAlts"
        -- UbxTupAlt and PolyAlt have only one alternative
 
+
+-------------------
+cgAlgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt]
+             -> FCode ( Maybe CmmAGraph
+                      , [(ConTagZ, CmmAGraph)] )
+cgAlgAltRhss gc_plan bndr alts
+  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
+
+       ; let { mb_deflt = case tagged_cmms of
+                           ((DEFAULT,rhs) : _) -> Just rhs
+                           _other              -> Nothing
+                            -- DEFAULT is always first, if present
+
+              ; branches = [ (dataConTagZ con, cmm)
+                           | (DataAlt con, cmm) <- tagged_cmms ]
+              }
+
+       ; return (mb_deflt, branches)
+       }
+
+
 -------------------
 cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)]
 cgAltRhss gc_plan bndr alts
@@ -617,35 +679,6 @@ emitEnter fun = do
   }
 
 
-
-{- Note [case on Bool]
-   ~~~~~~~~~~~~~~~~~~~
-A case on a Boolean value does two things:
-  1. It looks up the Boolean in a closure table and assigns the
-     result to the binder.
-  2. It branches to the True or False case through analysis
-     of the closure assigned to the binder.
-But the indirection through the closure table is unnecessary
-if the assignment to the binder will be dead code (use isDeadBndr).
-
-The following example illustrates how badly the code turns out:
-  STG:
-    case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 {
-      GHC.Types.False -> <true  code> // sbH8 dead
-      GHC.Types.True  -> <false code> // sbH8 dead
-    };
-  Cmm:
-    _s7HD::F64 = F64[_sbH7::I64 + 7];  // MidAssign
-    _ccsW::I64 = %MO_F_Le_W64(_s7Hx::F64, _s7HD::F64);  // MidAssign
-    // emitReturn  // MidComment
-    _sbH8::I64 = I64[ghczmprim_GHCziBool_Bool_closure_tbl + (_ccsW::I64 << 3)];  // MidAssign
-    _ccsX::I64 = _sbH8::I64 & 7;  // MidAssign
-    if (_ccsX::I64 >= 2) goto ccsH; else goto ccsI;  // LastCondBranch
-
-The assignments to _sbH8 and _ccsX are completely unnecessary.
-Instead, we should branch based on the value of _ccsW.
--}
-
 {- Note [Better Alt Heap Checks]
 If two function calls can share a return point, then they will also
 get the same info table. Therefore, it's worth our effort to make
index 16edc9c..f1a522b 100644 (file)
@@ -72,10 +72,7 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
               fc = ForeignConvention cconv arg_hints result_hints
               call_target = ForeignTarget cmm_target fc
 
-        ; srt <- getSRTInfo NoSRT        -- SLPJ: Not sure what SRT
-                                        -- is right here
-                                        -- JD: Does it matter in the new codegen?
-        ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
+        ; emitForeignCall safety results call_target call_args CmmMayReturn }
   where
         -- in the stdcall calling convention, the symbol needs @size appended
         -- to it, where size is the total number of bytes of arguments.  We
@@ -93,9 +90,7 @@ emitCCall :: [(CmmFormal,ForeignHint)]
           -> [(CmmActual,ForeignHint)]
           -> FCode ()
 emitCCall hinted_results fn hinted_args
-  = emitForeignCall PlayRisky results target args
-                    NoC_SRT -- No SRT b/c we PlayRisky
-                    CmmMayReturn
+  = emitForeignCall PlayRisky results target args CmmMayReturn
   where
     (args, arg_hints) = unzip hinted_args
     (results, result_hints) = unzip hinted_results
@@ -105,7 +100,7 @@ emitCCall hinted_results fn hinted_args
 
 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
 emitPrimCall res op args
-  = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn
+  = emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
 
 -- alternative entry point, used by CmmParse
 emitForeignCall
@@ -113,11 +108,10 @@ emitForeignCall
         -> [CmmFormal]          -- where to put the results
         -> ForeignTarget        -- the op
         -> [CmmActual]          -- arguments
-        -> C_SRT                -- the SRT of the calls continuation
         -> CmmReturnInfo        -- This can say "never returns"
                                 --   only RTS procedures do this
         -> FCode ()
-emitForeignCall safety results target args _srt _ret
+emitForeignCall safety results target args _ret
   | not (playSafe safety) = do
     let (caller_save, caller_load) = callerSaveVolatileRegs
     emit caller_save
index 68d078f..6533414 100644 (file)
@@ -151,9 +151,10 @@ mkStaticClosureFields
         :: CmmInfoTable
         -> CostCentreStack
         -> CafInfo
+        -> Bool                 -- SRT is non-empty?
         -> [CmmLit]             -- Payload
         -> [CmmLit]             -- The full closure
-mkStaticClosureFields info_tbl ccs caf_refs payload
+mkStaticClosureFields info_tbl ccs caf_refs has_srt payload
   = mkStaticClosure info_lbl ccs payload padding
         static_link_field saved_info_field
   where
@@ -178,8 +179,10 @@ mkStaticClosureFields info_tbl ccs caf_refs payload
         | otherwise  = ASSERT(null payload) [mkIntCLit 0]
 
     static_link_field
-        | is_caf || staticClosureNeedsLink info_tbl = [static_link_value]
-        | otherwise                                 = []
+        | is_caf || staticClosureNeedsLink has_srt info_tbl
+        = [static_link_value]
+        | otherwise
+        = []
 
     saved_info_field
         | is_caf     = [mkIntCLit 0]
index 1824ae9..c95b1f0 100644 (file)
@@ -14,7 +14,9 @@
 -- for details
 
 module StgCmmPrim (
-   cgOpApp
+   cgOpApp,
+   cgPrimOp -- internal(ish), used by cgCase to get code for a
+            -- comparison without also turning it into a Bool.
  ) where
 
 #include "HsVersions.h"
index 16f741e..246d57c 100644 (file)
@@ -71,6 +71,7 @@ import Module
 import Literal
 import Digraph
 import ListSetOps
+import VarSet
 import Util
 import Unique
 import DynFlags
@@ -811,36 +812,13 @@ assignTemp' e
 --
 -------------------------------------------------------------------------
 
--- There is just one SRT for each top level binding; all the nested
--- bindings use sub-sections of this SRT.  The label is passed down to
--- the nested bindings via the monad.
-
-getSRTInfo :: SRT -> FCode C_SRT
-getSRTInfo (SRTEntries {}) = return NoC_SRT --panic "getSRTInfo"
-
-getSRTInfo (SRT off len bmp)
-  | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
-  = do         { id <- newUnique
-       -- ; top_srt <- getSRTLabel
-        ; let srt_desc_lbl = mkLargeSRTLabel id
-        -- JD: We're not constructing and emitting SRTs in the back end,
-        -- which renders this code wrong (it now names a now-non-existent label).
-       -- ; emitRODataLits srt_desc_lbl
-        --      ( cmmLabelOffW top_srt off
-       --        : mkWordCLit (fromIntegral len)
-       --        : map mkWordCLit bmp)
-       ; return (C_SRT srt_desc_lbl 0 srt_escape) }
-
-  | otherwise
-  = do { top_srt <- getSRTLabel
-       ; return (C_SRT top_srt off (fromIntegral (head bmp))) }
-       -- The fromIntegral converts to StgHalfWord
-
-getSRTInfo NoSRT 
-  = -- TODO: Should we panic in this case?
-    -- Someone obviously thinks there should be an SRT
-    return NoC_SRT
-
+-- | Returns 'True' if there is a non-empty SRT, or 'False' otherwise
+-- NB. the SRT attached to an StgBind is still used in the new codegen
+-- to decide whether we need a static link field on a static closure
+-- or not.
+getSRTInfo :: SRT -> FCode Bool
+getSRTInfo (SRTEntries vs) = return (not (isEmptyVarSet vs))
+getSRTInfo _               = return False
 
 srt_escape :: StgHalfWord
 srt_escape = -1
index b818b01..a8fd604 100644 (file)
@@ -948,7 +948,8 @@ cmmExprConFold referenceKind expr = do
     dflags <- getDynFlags
     -- Skip constant folding if new code generator is running
     -- (this optimization is done in Hoopl)
-    let expr' = if dopt Opt_TryNewCodeGen dflags
+    -- SDM: re-enabled for now, while cmmRewriteAssignments is turned off
+    let expr' = if False -- dopt Opt_TryNewCodeGen dflags
                     then expr
                     else cmmExprCon (targetPlatform dflags) expr
     cmmExprNative referenceKind expr'