Catch too-large allocations and emit an error message (#4505)

[ghc-hetmet.git] / compiler / codeGen / StgCmmMonad.hs

diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index c1f743d..72f9cec 100644 (file)
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -10,7 +10,7 @@ module StgCmmMonad (
        FCode,  -- type
 
        initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
-       returnFC, fixC, nopC, whenC, 
+       returnFC, fixC, fixC_, nopC, whenC, 
        newUnique, newUniqSupply, 
 
        emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
@@ -63,7 +63,6 @@ import Id
 import VarEnv
 import OrdList
 import Unique
-import Util()
 import UniqSupply
 import FastString(sLit)
 import Outputable
@@ -149,6 +148,8 @@ fixC fcode = FCode (
                        result
        )
 
+fixC_ :: (a -> FCode a) -> FCode ()
+fixC_ fcode = fixC fcode >> return ()
 
 --------------------------------------------------------
 --     The code generator environment
@@ -213,6 +214,9 @@ data Sequel
                         -- space that's unused on this path?
                         -- We need to do this only if the expression may
                         -- allocate (e.g. it's a foreign call or allocating primOp)
+instance Show Sequel where
+  show (Return _) = "Sequel: Return"
+  show (AssignTo _ _) = "Sequel: Assign"
 
 initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
 initCgInfoDown dflags mod
@@ -255,7 +259,9 @@ data CgState
 data HeapUsage =
   HeapUsage {
        virtHp :: VirtualHpOffset,      -- Virtual offset of highest-allocated word
+                                       --   Incremented whenever we allocate
        realHp :: VirtualHpOffset       -- realHp: Virtual offset of real heap ptr
+                                       --   Used in instruction addressing modes
   }
 
 type VirtualHpOffset = WordOff
@@ -504,7 +510,7 @@ forkProc body_code
   = do { info_down <- getInfoDown
        ; us    <- newUniqSupply
        ; state <- getState
-       ; let   info_down' = info_down { cgd_sequel = initSequel }
+       ; let   info_down' = info_down -- { cgd_sequel = initSequel }
                 fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
                (result, fork_state_out) = doFCode body_code info_down' fork_state_in
        ; setState $ state `addCodeBlocksFrom` fork_state_out
@@ -530,22 +536,22 @@ forkAlts :: [FCode a] -> FCode [a]
 -- that the virtual Hp is moved on to the worst virtual Hp for the branches
 
 forkAlts branch_fcodes
-  = do { info_down <- getInfoDown
-       ; us <- newUniqSupply
-       ; state <- getState
-       ; let compile us branch 
-               = (us2, doFCode branch info_down branch_state)
-               where
-                 (us1,us2) = splitUniqSupply us
-                 branch_state = (initCgState us1) {
-                                       cgs_binds   = cgs_binds state,
-                                       cgs_hp_usg  = cgs_hp_usg state }
-
-             (_us, results) = mapAccumL compile us branch_fcodes
-             (branch_results, branch_out_states) = unzip results
-       ; setState $ foldl stateIncUsage state branch_out_states
-               -- NB foldl.  state is the *left* argument to stateIncUsage
-       ; return branch_results }
+  = do  { info_down <- getInfoDown
+        ; us <- newUniqSupply
+        ; state <- getState
+        ; let compile us branch
+                = (us2, doFCode branch info_down branch_state)
+                where
+                  (us1,us2) = splitUniqSupply us
+                  branch_state = (initCgState us1) {
+                                        cgs_binds   = cgs_binds state,
+                                        cgs_hp_usg  = cgs_hp_usg state }
+
+              (_us, results) = mapAccumL compile us branch_fcodes
+              (branch_results, branch_out_states) = unzip results
+        ; setState $ foldl stateIncUsage state branch_out_states
+                -- NB foldl.  state is the *left* argument to stateIncUsage
+        ; return branch_results }
 
 -- collect the code emitted by an FCode computation
 getCodeR :: FCode a -> FCode (a, CmmAGraph)
@@ -597,14 +603,15 @@ emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
                           CmmAGraph -> FCode ()
 emitProcWithConvention conv info lbl args blocks
   = do  { us <- newUniqSupply
-        ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
-              blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks
-        ; let proc_block = CmmProc info lbl args blks
+        ; let (uniq, us') = takeUniqFromSupply us
+              (offset, entry) = mkEntry (mkBlockId uniq) conv args
+              blks = initUs_ us' $ lgraphOfAGraph $ entry <*> blocks
+        ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
         ; state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
 emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
-emitProc = emitProcWithConvention Native
+emitProc = emitProcWithConvention NativeNodeCall
 
 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
 emitSimpleProc lbl code = 
@@ -630,5 +637,5 @@ getCmm code
 cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
 cgStmtsToBlocks stmts
   = do  { us <- newUniqSupply
-       ; return (initUs_ us (lgraphOfAGraph 0 stmts)) }        
+       ; return (initUs_ us (lgraphOfAGraph stmts)) }