[project @ 2002-10-15 13:20:18 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 f270795..d41fcaf 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.29 2001/12/12 12:19:11 simonmar Exp $
+% $Id: CgHeapery.lhs,v 1.34 2002/09/13 15:02:28 simonpj Exp $
 %
 \section[CgHeapery]{Heap management functions}
 
@@ -30,13 +30,14 @@ import ClosureInfo  ( closureSize, closureGoodStuffSize,
                        )
 import PrimRep         ( PrimRep(..), isFollowableRep )
 import Unique          ( Unique )
-import CmdLineOpts     ( opt_SccProfilingOn, opt_GranMacros )
-import GlaExts
+import CmdLineOpts     ( opt_GranMacros )
 import Outputable
 
 #ifdef DEBUG
 import PprAbsC         ( pprMagicId ) -- tmp
 #endif
+
+import GLAEXTS
 \end{code}
 
 %************************************************************************
@@ -118,7 +119,7 @@ fastEntryChecks regs tags ret node_points code
         = mkAbstractCs 
          [ real_check,
             if hp == 0 then AbsCNop 
-           else profCtrAbsC SLIT("TICK_ALLOC_HEAP") 
+           else profCtrAbsC FSLIT("TICK_ALLOC_HEAP") 
                  [ mkIntCLit hp, CLbl ctr DataPtrRep ]
          ]
 
@@ -235,7 +236,8 @@ have to do something about saving and restoring the other registers.
 
 \begin{code}
 altHeapCheck 
-       :: Bool                         -- is an algebraic alternative
+       :: Bool                         -- is a polymorphic case alt
+       -> Bool                         -- is an primitive case alt
        -> [MagicId]                    -- live registers
        -> [(VirtualSpOffset,Int)]      -- stack slots to tag
        -> AbstractC
@@ -246,7 +248,7 @@ altHeapCheck
 -- unboxed tuple alternatives and let-no-escapes (the two most annoying
 -- constructs to generate code for!):
 
-altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
+altHeapCheck is_poly is_prim regs tags fail_code (Just ret_addr) code
   = mkTagAssts tags `thenFC` \tag_assts1 ->
     let tag_assts = mkAbstractCs [fail_code, tag_assts1]
     in
@@ -258,7 +260,7 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
                  then  AbsCNop
                  else  mkAbstractCs 
                        [ checking_code tag_assts,
-                         profCtrAbsC SLIT("TICK_ALLOC_HEAP") 
+                         profCtrAbsC FSLIT("TICK_ALLOC_HEAP") 
                            [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
                        ]
        )  `thenC`
@@ -307,7 +309,7 @@ altHeapCheck is_fun regs tags fail_code (Just ret_addr) code
 
 -- normal algebraic and primitive case alternatives:
 
-altHeapCheck is_fun regs [] AbsCNop Nothing code
+altHeapCheck is_poly is_prim regs [] AbsCNop Nothing code
   = initHeapUsage (\ hHw -> do_heap_chk hHw `thenC` code)
   where
     do_heap_chk :: HeapOffset -> Code
@@ -317,7 +319,7 @@ altHeapCheck is_fun regs [] AbsCNop Nothing code
                 then  AbsCNop
                 else  mkAbstractCs 
                       [ checking_code,
-                        profCtrAbsC SLIT("TICK_ALLOC_HEAP") 
+                        profCtrAbsC FSLIT("TICK_ALLOC_HEAP") 
                            [ mkIntCLit words_required, CLbl ctr DataPtrRep ]
                       ]
        )  `thenC`
@@ -333,28 +335,21 @@ 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.
+           -- R1 is boxed, but unlifted: DO NOT enter R1 when we return.
+           --
+           -- We also lump the polymorphic case in here, because we don't
+           -- want to enter R1 if it is a function, and we're guarnateed
+           -- that the return point has a direct return.
            [VanillaReg rep 1#]
-               |  rep == PtrRep
-               && is_fun ->
-                 CCheck HP_CHK_SEQ_NP
-                       [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
-                       AbsCNop
+               | isFollowableRep rep && (is_poly || is_prim) ->
+                 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
 
            -- R1 is lifted (the common case)
-           [VanillaReg rep 1#]
-               | rep == PtrRep ->
-                 CCheck HP_CHK_NP
+               | isFollowableRep rep ->
+                 CCheck HP_CHK_NP
                        [mkIntCLit words_required, mkIntCLit 1{-regs live-}]
                        AbsCNop
 
-           -- R1 is boxed, but unlifted
-               | isFollowableRep rep ->
-                 CCheck HP_CHK_UNPT_R1 [mkIntCLit words_required] AbsCNop
-
            -- R1 is unboxed
                | otherwise ->
                  CCheck HP_CHK_UNBX_R1 [mkIntCLit words_required] AbsCNop