Better handling of node parameter in calling conventions

 - Previously, the node was taken as a parameter, then ignored,
   for static closures. Goofy. Now, the vestigial node parameters
   are gone.

diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 990e178..b9df541 100644 (file)
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -171,12 +171,11 @@ assign_bits_reg :: SlotAssigner -> Width -> WordOff -> VGcPtr -> AvailRegs -> As
 assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type"
 assign_bits_reg _ w off gcp (v:vs, fs, ds, ls)
   | widthInBits w <= widthInBits wordWidth =
-        pprTrace "long regs" (ppr ls <+> ppr wordWidth <+> ppr mAX_Real_Long_REG) $ (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls))
+        (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls))
 assign_bits_reg _ w off _ (vs, fs, ds, l:ls)
   | widthInBits w > widthInBits wordWidth =
-        pprTrace "long regs" (ppr ls <+> ppr wordWidth <+> ppr mAX_Real_Long_REG) $ (RegisterParam l, off, 0, (vs, fs, ds, ls))
-assign_bits_reg assign_slot w off _ regs@(_, _, _, ls) =
-  pprTrace "long regs" (ppr w <+> ppr ls <+> ppr wordWidth <+> ppr mAX_Real_Long_REG <+> ppr mAX_Long_REG) $ assign_slot w off regs
+        (RegisterParam l, off, 0, (vs, fs, ds, ls))
+assign_bits_reg assign_slot w off _ regs@(_, _, _, ls) = assign_slot w off regs
 
 assign_float_reg :: SlotAssigner -> Width -> WordOff -> AvailRegs -> Assignment
 assign_float_reg _ W32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, 0, (vs, fs, ds, ls))

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 60d6ce1..12997dd 100644 (file)
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -453,13 +453,20 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
      let to_proc (bid, g) | elemBlockSet bid callPPs =
            if bid == entry then 
-             CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
+             CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g)
            else
-             CmmProc emptyContInfoTable lbl [] g
+             CmmProc emptyContInfoTable lbl [] (replacePPIds g)
            where lbl = expectJust "pp label" $ lookupFM procLabels bid
          to_proc (bid, g) =
-           CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g
+           CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)
              where lbl = expectJust "pp label" $ lookupFM procLabels bid
+         -- References to procpoint IDs can now be replaced with the infotable's label
+         replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g)
+           where repl e@(CmmLit (CmmBlock bid)) =
+                   case lookupFM procLabels bid of
+                     Just l  -> CmmLit (CmmLabel (entryLblToInfoLbl l))
+                     Nothing -> e
+                 repl e = e
      -- The C back end expects to see return continuations before the call sites.
      -- Here, we sort them in reverse order -- it gets reversed later.
      let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 4eabffb..2894ece 100644 (file)
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -262,8 +262,6 @@ mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results
 
 -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
 mkCall f (callConv, retConv) results actuals updfr_off =
- pprTrace "mkCall" (ppr f <+> ppr actuals <+> ppr results <+> ppr callConv <+>
-                    ppr retConv) $
   withFreshLabel "call successor" $ \k ->
     let area = CallArea $ Young k
         (off, copyin) = copyInOflow retConv area results

diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index e306dd1..8c7c434 100644 (file)
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -467,13 +467,15 @@ emitClosureProcAndInfoTable :: Bool                    -- top-level?
                             -> FCode ()
 emitClosureProcAndInfoTable top_lvl bndr cl_info args body
  = do  { let lf_info = closureLFInfo cl_info
-       -- Bind the binder itself, but only if it's not a top-level
+        -- Bind the binder itself, but only if it's not a top-level
         -- binding. We need non-top let-bindings to refer to the
         -- top-level binding, which this binding would incorrectly shadow.
         ; node <- if top_lvl then return $ idToReg (NonVoid bndr)
                   else bindToReg (NonVoid bndr) lf_info
+        ; let node_points = nodeMustPointToIt lf_info
         ; arg_regs <- bindArgsToRegs args
-        ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs)
+        ; let args' = if node_points then (node : arg_regs) else arg_regs
+        ; emitClosureAndInfoTable cl_info args' $ body (node, arg_regs)
         }
 
 -- Data constructors need closures, but not with all the argument handling
@@ -482,7 +484,9 @@ emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode ()
 emitClosureAndInfoTable cl_info args body
   = do { info <- mkCmmInfo cl_info
        ; blks <- getCode body
-       ; emitProc info (infoLblToEntryLbl info_lbl) args blks
+       ; let conv = if nodeMustPointToIt (closureLFInfo cl_info) then NativeNodeCall
+                    else NativeDirectCall
+       ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks
        }
   where
     info_lbl = infoTableLabelFromCI cl_info