[project @ 1999-05-26 14:12:07 by simonmar]

[ghc-hetmet.git] / ghc / compiler / codeGen / CgHeapery.lhs

diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index f1a0ef2..80d968f 100644 (file)
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgHeapery.lhs,v 1.12 1999/01/21 10:31:56 simonm Exp $
+% $Id: CgHeapery.lhs,v 1.17 1999/05/26 14:12:13 simonmar Exp $
 %
 \section[CgHeapery]{Heap management functions}
 
@@ -21,7 +21,7 @@ import CLabel
 import CgMonad
 
 import CgStackery      ( getFinalStackHW, mkTaggedStkAmodes, mkTagAssts )
-import SMRep           ( fixedHdrSize, getSMRepStr )
+import SMRep           ( fixedHdrSize )
 import AbsCUtils       ( mkAbstractCs, getAmodeRep )
 import CgUsages                ( getVirtAndRealHp, getRealSp, setVirtHp, setRealHp,
                          initHeapUsage
@@ -31,6 +31,7 @@ import ClosureInfo    ( closureSize, closureGoodStuffSize,
                          closureSMRep
                        )
 import PrimRep         ( PrimRep(..), isFollowableRep )
+import Unique          ( Unique )
 import CmdLineOpts     ( opt_SccProfilingOn )
 import GlaExts
 import Outputable
@@ -226,7 +227,7 @@ altHeapCheck
        -> [MagicId]                    -- live registers
        -> [(VirtualSpOffset,Int)]      -- stack slots to tag
        -> AbstractC
-       -> Maybe CLabel                 -- ret address if not on top of stack.
+       -> Maybe Unique                 -- uniq of ret address (possibly)
        -> Code
        -> Code
 
@@ -251,6 +252,12 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
        checking_code tag_assts = 
          case non_void_regs of
 
+{- no: there might be stuff on top of the retn. addr. on the stack.
+           [{-no regs-}] ->
+               CCheck HP_CHK_NOREGS
+                   [mkIntCLit words_required]
+                   tag_assts
+-}
            -- this will cover all cases for x86
            [VanillaReg rep ILIT(1)] 
 
@@ -258,14 +265,14 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
                  CCheck HP_CHK_UT_ALT
                      [mkIntCLit words_required, mkIntCLit 1, mkIntCLit 0,
                        CReg (VanillaReg RetRep ILIT(2)),
-                       CLbl ret_addr RetRep]
+                       CLbl (mkReturnInfoLabel ret_addr) RetRep]
                      tag_assts
 
               | otherwise ->
                  CCheck HP_CHK_UT_ALT
                      [mkIntCLit words_required, mkIntCLit 0, mkIntCLit 1,
                        CReg (VanillaReg RetRep ILIT(2)),
-                       CLbl ret_addr RetRep]
+                       CLbl (mkReturnInfoLabel ret_addr) RetRep]
                      tag_assts
 
            several_regs ->
@@ -274,7 +281,10 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
                CCheck HP_CHK_GEN
                     [mkIntCLit words_required, 
                      mkIntCLit (IBOX(word2Int# liveness)),
-                     CLbl ret_addr RetRep] 
+                       -- HP_CHK_GEN needs a direct return address,
+                       -- not an info table (might be different if
+                       -- we're not assembly-mangling/tail-jumping etc.)
+                     CLbl (mkReturnPtLabel ret_addr) RetRep] 
                     tag_assts
 
 -- normal algebraic and primitive case alternatives:
@@ -300,6 +310,9 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code
               CCheck HP_CHK_NOREGS [mkIntCLit words_required] AbsCNop
 
            -- The SEQ case (polymophic/function typed case branch)
+           -- We need this case because the closure in Node won't return
+           -- directly when we enter it (it could be a function), so the
+           -- heap check code needs to push a seq frame on top of the stack.
            [VanillaReg rep ILIT(1)]
                |  rep == PtrRep
                && is_fun ->
@@ -341,11 +354,10 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code
 -- build up a bitmap of the live pointer registers
 
 mkRegLiveness :: [MagicId] -> Word#
-mkRegLiveness [] = int2Word# 0#
-mkRegLiveness (VanillaReg rep i : regs) 
-   | isFollowableRep rep = ((int2Word# 1#) `shiftL#` (i -# 1#)) 
-                               `or#` mkRegLiveness regs
-   | otherwise           = mkRegLiveness regs
+mkRegLiveness []  =  int2Word# 0#
+mkRegLiveness (VanillaReg rep i : regs) | isFollowableRep rep 
+  =  ((int2Word# 1#) `shiftL#` (i -# 1#)) `or#` mkRegLiveness regs
+mkRegLiveness (_ : regs)  =  mkRegLiveness regs
 
 -- Emit macro for simulating a fetch and then reschedule
 
@@ -446,7 +458,6 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
 
        -- GENERATE CC PROFILING MESSAGES
     costCentresC SLIT("CCS_ALLOC") [blame_cc, mkIntCLit closure_size]
-       -- CLitLit (_PK_ type_str) IntRep] -- not necessary? --SDM
                                                        `thenC`
 
        -- BUMP THE VIRTUAL HEAP POINTER
@@ -457,7 +468,6 @@ allocDynClosure closure_info use_cc blame_cc amodes_with_offsets
   where
     closure_size = closureSize closure_info
     slop_size    = slopSize closure_info
-    type_str     = getSMRepStr (closureSMRep closure_info)
 
 -- Avoid hanging on to anything in the CC field when we're not profiling.