Fix an egregious strictness analyser bug (Trac #4924)

[ghc-hetmet.git] / compiler / cmm / MkZipCfgCmm.hs

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index b47185b..46f0659 100644 (file)
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -35,7 +35,6 @@ import PprCmm()
 import FastString
 import ForeignCall
 import MkZipCfg
-import Outputable
 import Panic 
 import SMRep (ByteOff) 
 import StaticFlags 
@@ -64,11 +63,11 @@ mkCall       :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals
                   UpdFrameOffset -> CmmAGraph
 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
                   UpdFrameOffset -> CmmAGraph
-                       -- Native C-- calling convention
-mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+  -- Native C-- calling convention
+mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
 mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
 mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-                -- Never returns; like exit() or barf()
+  -- Never returns; like exit() or barf()
 
 ---------- Control transfer
 mkJump         ::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
@@ -132,9 +131,9 @@ mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
 mkSwitch e tbl            = mkLast $ LastSwitch e tbl
 
-mkSafeCall   t fs as upd =
+mkSafeCall   t fs as upd interruptible =
   withFreshLabel "safe call" $ \k ->
-    mkMiddle $ MidForeignCall (Safe k upd) t fs as
+    mkMiddle $ MidForeignCall (Safe k upd interruptible) t fs as
 mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
 
 -- For debugging purposes, we can stub out dead stack slots:
@@ -146,31 +145,30 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
 -- the variables in their spill slots.
 -- Therefore, for copying arguments and results, we provide different
 -- functions to pass the arguments in an overflow area and to pass them in spill slots.
-copyInOflow  :: Convention -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph)
-copyInSlot   :: Convention -> Bool -> CmmFormals -> CmmAGraph
+copyInOflow  :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
+copyInSlot   :: Convention -> CmmFormals -> CmmAGraph
 copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
                               (Int, [Middle])
-copyOutSlot  :: Convention -> Transfer -> [LocalReg] -> [Middle]
+copyOutSlot  :: Convention -> [LocalReg] -> [Middle]
   -- why a list of middles here instead of an AGraph?
 
 copyInOflow      = copyIn oneCopyOflowI
-copyInSlot c i f = snd $ copyIn oneCopySlotI c i (panic "no area for copying to slots") f
+copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
 
 type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
                           (ByteOff, CmmAGraph)
-type CopyIn  = SlotCopier -> Convention -> Bool -> Area -> CmmFormals ->
-                          (ByteOff, CmmAGraph)
+type CopyIn  = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph)
 
 -- Return the number of bytes used for copying arguments, as well as the
 -- instructions to copy the arguments.
 copyIn :: CopyIn
-copyIn oflow conv isCall area formals =
+copyIn oflow conv area formals =
   foldr ci (init_offset, mkNop) args'
   where ci (reg, RegisterParam r) (n, ms) =
           (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
         ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
         init_offset = widthInBytes wordWidth -- infotable
-        args  = assignArgumentsPos conv isCall localRegType formals
+        args  = assignArgumentsPos conv localRegType formals
         args' = foldl adjust [] args
           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                 adjust rst x@(_, RegisterParam _) = x : rst
@@ -208,7 +206,7 @@ copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
                          widthInBytes wordWidth)
                       else ([], 0)
                     Old -> ([], updfr_off)
-        args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals
+        args = assignArgumentsPos conv cmmExprType actuals
         args' = foldl adjust setRA args
           where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                 adjust rst x@(_, RegisterParam _) = x : rst
@@ -216,19 +214,19 @@ copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register
 
 -- Args passed only in registers and stack slots; no overflow space.
 -- No return address may apply!
-copyOutSlot conv transfer actuals = foldr co [] args
+copyOutSlot conv actuals = foldr co [] args
   where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
         co (v, StackParam off)  ms =
           MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
         toExp r = CmmReg (CmmLocal r)
-        args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals
+        args = assignArgumentsPos conv localRegType actuals
 
 -- oneCopySlotO _ (reg, _) (n, ms) =
 --   (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
 --   where w = widthInBytes (typeWidth (localRegType reg))
 
 mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
-mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals
+mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals
 
 lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
                 (ByteOff -> Last) -> CmmAGraph
@@ -263,11 +261,9 @@ 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 False area results
+        (off, copyin) = copyInOflow retConv area results
         copyout = lastWithArgs Call area callConv actuals updfr_off 
                                (toCall f (Just k) updfr_off off)
     in (copyout <*> mkLabel k <*> copyin)