Produce new-style Cmm from the Cmm parser

The main change here is that the Cmm parser now allows high-level cmm
code with argument-passing and function calls.  For example:

foo ( gcptr a, bits32 b )
{
  if (b > 0) {
     // we can make tail calls passing arguments:
     jump stg_ap_0_fast(a);
  }

  return (x,y);
}

More details on the new cmm syntax are in Note [Syntax of .cmm files]
in CmmParse.y.

The old syntax is still more-or-less supported for those occasional
code fragments that really need to explicitly manipulate the stack.
However there are a couple of differences: it is now obligatory to
give a list of live GlobalRegs on every jump, e.g.

  jump %ENTRY_CODE(Sp(0)) [R1];

Again, more details in Note [Syntax of .cmm files].

I have rewritten most of the .cmm files in the RTS into the new
syntax, except for AutoApply.cmm which is generated by the genapply
program: this file could be generated in the new syntax instead and
would probably be better off for it, but I ran out of enthusiasm.

Some other changes in this batch:

 - The PrimOp calling convention is gone, primops now use the ordinary
   NativeNodeCall convention.  This means that primops and "foreign
   import prim" code must be written in high-level cmm, but they can
   now take more than 10 arguments.

 - CmmSink now does constant-folding (should fix #7219)

 - .cmm files now go through the cmmPipeline, and as a result we
   generate better code in many cases.  All the object files generated
   for the RTS .cmm files are now smaller.  Performance should be
   better too, but I haven't measured it yet.

 - RET_DYN frames are removed from the RTS, lots of code goes away

 - we now have some more canned GC points to cover unboxed-tuples with
   2-4 pointers, which will reduce code size a little.

compiler/cmm/CLabel.hs

@@ -72,7 +72,7 @@ module CLabel (
         mkCmmRetLabel,
         mkCmmCodeLabel,
         mkCmmDataLabel,
-        mkCmmGcPtrLabel,
+        mkCmmClosureLabel,
 
         mkRtsApFastLabel,
 
@@ -331,7 +331,7 @@ data CmmLabelInfo
   | CmmRet                      -- ^ misc rts return points,    suffix _ret
   | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure
   | CmmCode                     -- ^ misc rts code
-  | CmmGcPtr                    -- ^ GcPtrs eg CHARLIKE_closure
+  | CmmClosure                  -- ^ closures eg CHARLIKE_closure
   | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code
   deriving (Eq, Ord)
 
@@ -418,7 +418,7 @@ mkCAFBlackHoleEntryLabel        = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOL
 
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
-  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmGcPtrLabel
+  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel
         :: PackageId -> FastString -> CLabel
 
 mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo
@@ -427,7 +427,7 @@ mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo
 mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet
 mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode
 mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData
-mkCmmGcPtrLabel     pkg str     = CmmLabel pkg str CmmGcPtr
+mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure
 
 
 -- Constructing RtsLabels
@@ -543,6 +543,7 @@ mkPlainModuleInitLabel mod      = PlainModuleInitLabel mod
 
 toClosureLbl :: CLabel -> CLabel
 toClosureLbl (IdLabel n c _) = IdLabel n c Closure
+toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
 toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
 
 toSlowEntryLbl :: CLabel -> CLabel
@@ -774,7 +775,7 @@ isGcPtrLabel lbl = case labelType lbl of
 --    whether it be code, data, or static GC object.
 labelType :: CLabel -> CLabelType
 labelType (CmmLabel _ _ CmmData)                = DataLabel
-labelType (CmmLabel _ _ CmmGcPtr)               = GcPtrLabel
+labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel
 labelType (CmmLabel _ _ CmmCode)                = CodeLabel
 labelType (CmmLabel _ _ CmmInfo)                = DataLabel
 labelType (CmmLabel _ _ CmmEntry)               = CodeLabel
@@ -1001,7 +1002,6 @@ pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi
 
 pprCLbl (CmmLabel _ str CmmCode)        = ftext str
 pprCLbl (CmmLabel _ str CmmData)        = ftext str
-pprCLbl (CmmLabel _ str CmmGcPtr)       = ftext str
 pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str
 
 pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> ptext (sLit "_fast")
@@ -1046,6 +1046,9 @@ pprCLbl (CmmLabel _ fs CmmRetInfo)
 pprCLbl (CmmLabel _ fs CmmRet)
   = ftext fs <> ptext (sLit "_ret")
 
+pprCLbl (CmmLabel _ fs CmmClosure)
+  = ftext fs <> ptext (sLit "_closure")
+
 pprCLbl (RtsLabel (RtsPrimOp primop))
   = ptext (sLit "stg_") <> ppr primop
 

compiler/cmm/Cmm.hs

@@ -109,9 +109,14 @@ data CmmStackInfo
                -- number of bytes of arguments on the stack on entry to the
                -- the proc.  This is filled in by StgCmm.codeGen, and used
                -- by the stack allocator later.
-       updfr_space :: Maybe ByteOff
+       updfr_space :: Maybe ByteOff,
                -- XXX: this never contains anything useful, but it should.
                -- See comment in CmmLayoutStack.
+       do_layout :: Bool
+               -- Do automatic stack layout for this proc.  This is
+               -- True for all code generated by the code generator,
+               -- but is occasionally False for hand-written Cmm where
+               -- we want to do the stack manipulation manually.
   }
 
 -- | Info table as a haskell data type

compiler/cmm/CmmBuildInfoTables.hs

@@ -235,8 +235,8 @@ to_SRT dflags top_srt off len bmp
            tbl = CmmData RelocatableReadOnlyData $
                    Statics srt_desc_lbl $ map CmmStaticLit
                      ( cmmLabelOffW dflags top_srt off
-                     : mkWordCLit dflags (toStgWord dflags (fromIntegral len))
-                     : map (mkWordCLit dflags) bmp)
+                     : mkWordCLit dflags (fromIntegral len)
+                     : map (mkStgWordCLit dflags) bmp)
        return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
   | otherwise
   = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
@@ -252,7 +252,8 @@ localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
 localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
 localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
   case topInfoTable proc of
-    Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep)
+    Just (CmmInfoTable { cit_rep = rep })
+      | not (isStaticRep rep) && not (isStackRep rep)
       -> (cafs, Just (toClosureLbl top_l))
     _other -> (cafs, Nothing)
   where

compiler/cmm/CmmCallConv.hs

@@ -8,7 +8,8 @@
 module CmmCallConv (
   ParamLocation(..),
   assignArgumentsPos,
-  globalArgRegs
+  assignStack,
+  globalArgRegs, realArgRegs
 ) where
 
 #include "HsVersions.h"
@@ -18,7 +19,6 @@ import SMRep
 import Cmm (Convention(..))
 import PprCmm ()
 
-import qualified Data.List as L
 import DynFlags
 import Outputable
 
@@ -33,39 +33,37 @@ instance Outputable ParamLocation where
   ppr (RegisterParam g) = ppr g
   ppr (StackParam p)    = ppr p
 
--- | JD: For the new stack story, I want arguments passed on the stack to manifest as
--- positive offsets in a CallArea, not negative offsets from the stack pointer.
--- Also, I want byte offsets, not word offsets.
-assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
-                      [(a, ParamLocation)]
+-- |
 -- Given a list of arguments, and a function that tells their types,
 -- return a list showing where each argument is passed
-assignArgumentsPos dflags conv arg_ty reps = assignments
-    where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
+--
+assignArgumentsPos :: DynFlags
+                   -> ByteOff           -- stack offset to start with
+                   -> Convention
+                   -> (a -> CmmType)    -- how to get a type from an arg
+                   -> [a]               -- args
+                   -> (
+                        ByteOff              -- bytes of stack args
+                      , [(a, ParamLocation)] -- args and locations
+                      )
+
+assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
+    where
       regs = case (reps, conv) of
                (_,   NativeNodeCall)   -> getRegsWithNode dflags
                (_,   NativeDirectCall) -> getRegsWithoutNode dflags
                ([_], NativeReturn)     -> allRegs dflags
                (_,   NativeReturn)     -> getRegsWithNode dflags
                -- GC calling convention *must* put values in registers
                (_,   GC)               -> allRegs dflags
-               (_,   PrimOpCall)       -> allRegs dflags
-               ([_], PrimOpReturn)     -> allRegs dflags
-               (_,   PrimOpReturn)     -> getRegsWithNode dflags
                (_,   Slow)             -> noRegs
       -- The calling conventions first assign arguments to registers,
       -- then switch to the stack when we first run out of registers
-      -- (even if there are still available registers for args of a different type).
-      -- When returning an unboxed tuple, we also separate the stack
-      -- arguments by pointerhood.
-      (reg_assts, stk_args) = assign_regs [] reps regs
-      stk_args' = case conv of NativeReturn -> part
-                               PrimOpReturn -> part
-                               GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
-                               _            -> stk_args
-                  where part = uncurry (++)
-                                       (L.partition (not . isGcPtrType . arg_ty) stk_args)
-      stk_assts = assign_stk 0 [] (reverse stk_args')
+      -- (even if there are still available registers for args of a
+      -- different type).  When returning an unboxed tuple, we also
+      -- separate the stack arguments by pointerhood.
+      (reg_assts, stk_args)  = assign_regs [] reps regs
+      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args
       assignments = reg_assts ++ stk_assts
 
       assign_regs assts []     _    = (assts, [])
@@ -88,11 +86,21 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
               gcp | isGcPtrType ty = VGcPtr
                   | otherwise  	   = VNonGcPtr
 
-      assign_stk _      assts [] = assts
-      assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
+
+assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
+            -> (
+                 ByteOff              -- bytes of stack args
+               , [(a, ParamLocation)] -- args and locations
+               )
+assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
+ where
+      assign_stk offset assts [] = (offset, assts)
+      assign_stk offset assts (r:rs)
+        = assign_stk off' ((r, StackParam off') : assts) rs
         where w    = typeWidth (arg_ty r)
-              size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags
+              size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size
               off' = offset + size
+              word_size = wORD_SIZE dflags
 
 -----------------------------------------------------------------------------
 -- Local information about the registers available
@@ -158,3 +166,9 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
                        allFloatRegs dflags ++
                        allDoubleRegs dflags ++
                        allLongRegs dflags
+
+realArgRegs :: DynFlags -> [GlobalReg]
+realArgRegs dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
+                realFloatRegs dflags ++
+                realDoubleRegs dflags ++
+                realLongRegs dflags

compiler/cmm/CmmContFlowOpt.hs

@@ -97,15 +97,17 @@ cmmCfgOptsProc _ top = top
 
 blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
 blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
-  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
   where
-     -- we might be able to shortcut the entry BlockId itself
-     new_entry
+     -- we might be able to shortcut the entry BlockId itself.
+     -- remember to update the shortcut_map', since we also have to
+     -- update the info_tbls mapping now.
+     (new_entry, shortcut_map')
        | Just entry_blk <- mapLookup entry_id new_blocks
        , Just dest      <- canShortcut entry_blk
-       = dest
+       = (dest, mapInsert entry_id dest shortcut_map)
        | otherwise
-       = entry_id
+       = (entry_id, shortcut_map)
 
      blocks = postorderDfs g
      blockmap = foldr addBlock emptyBody blocks

compiler/cmm/CmmCvt.hs

@@ -22,19 +22,23 @@ cmmOfZgraph tops = map mapTop tops
   where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
         mapTop (CmmData s ds) = CmmData s ds
 
-data ValueDirection = Arguments | Results
+add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
+add_hints args hints = zipWith Old.CmmHinted args hints
 
-add_hints :: ForeignTarget -> ValueDirection -> [a] -> [Old.CmmHinted a]
-add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
-
-get_hints :: ForeignTarget -> ValueDirection -> [ForeignHint]
-get_hints (ForeignTarget _ (ForeignConvention _ hints _)) Arguments = hints
-get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results   = hints
-get_hints (PrimTarget _) _vd = repeat NoHint
+get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
+                             arg_hints ++ repeat NoHint)
+  where (res_hints, arg_hints) = callishMachOpHints op
+get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
+  = (res_hints, arg_hints)
 
 cmm_target :: ForeignTarget -> Old.CmmCallTarget
 cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
-cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
+cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc
+
+get_ret :: ForeignTarget -> CmmReturnInfo
+get_ret (PrimTarget _) = CmmMayReturn
+get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
 
 ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
 ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
@@ -83,11 +87,14 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
                             CmmAssign l r                                  -> Old.CmmAssign l r
                             CmmStore  l r                                  -> Old.CmmStore  l r
                             CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
-                            CmmUnsafeForeignCall target ress args          -> 
+                            CmmUnsafeForeignCall target ress args          ->
                               Old.CmmCall (cmm_target target)
-                                          (add_hints target Results   ress)
-                                          (add_hints target Arguments args)
-                                          Old.CmmMayReturn
+                                          (add_hints ress res_hints)
+                                          (add_hints args arg_hints)
+                                          (get_ret target)
+                                  where
+                                     (res_hints, arg_hints) = get_hints target
+
 
                   last :: CmmNode O C -> () -> [Old.CmmStmt]
                   last node _ = stmts