[project @ 2004-04-02 16:54:02 by simonpj]

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

diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index a14b77a..88083f7 100644 (file)
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgMonad.lhs,v 1.37 2003/01/07 14:31:20 simonmar Exp $
+% $Id: CgMonad.lhs,v 1.39 2003/07/02 13:12:38 simonpj Exp $
 %
 \section[CgMonad]{The code generation monad}
 
@@ -60,8 +60,10 @@ import CmdLineOpts   ( opt_SccProfilingOn, opt_DoTickyProfiling )
 import Module          ( Module )
 import DataCon         ( ConTag )
 import Id              ( Id )
+import Name            ( Name )
 import VarEnv
 import PrimRep         ( PrimRep(..) )
+import SMRep           ( StgHalfWord, hALF_WORD )
 import FastString
 import Outputable
 
@@ -149,9 +151,8 @@ data Sequel
 type SemiTaggingStuff
   = Maybe                          -- Maybe[1] we don't have any semi-tagging stuff...
      ([(ConTag, JoinDetails)],     -- Alternatives
-      Maybe (Maybe Id, JoinDetails) -- Default (but Maybe[2] we don't have one)
-                                   -- Maybe[3] the default is a
-                                   -- bind-default (Just b); that is,
+      Maybe (Id, JoinDetails)      -- Default (but Maybe[2] we don't have one)
+                                   -- The default branch expects a 
                                    -- it expects a ptr to the thing
                                    -- in Node, bound to b
      )
@@ -444,19 +445,16 @@ that
        - the virtual Hp is moved on to the worst virtual Hp for the branches
 
 \begin{code}
-forkAlts :: [FCode a] -> FCode b -> FCode ([a],b)
-
-forkAlts branch_fcodes (FCode deflt_fcode) = 
-       do
-               info_down <- getInfoDown
-               in_state <- getState
-               let compile (FCode fc) = fc info_down in_state
-               let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
-               let (deflt_result, deflt_out_state) = deflt_fcode info_down in_state
-               setState $ foldl stateIncUsage in_state (deflt_out_state:branch_out_states)
-                               -- NB foldl.  in_state is the *left* argument to stateIncUsage
-               return (branch_results, deflt_result)
-
+forkAlts :: [FCode a] -> FCode [a]
+
+forkAlts branch_fcodes
+  = do info_down <- getInfoDown
+       in_state  <- getState
+       let compile (FCode fc)                  = fc info_down in_state
+       let (branch_results, branch_out_states) = unzip (map compile branch_fcodes)
+       setState $ foldl stateIncUsage in_state branch_out_states
+                       -- NB foldl.  in_state is the *left* argument to stateIncUsage
+       return branch_results
 \end{code}
 
 @forkEval@ takes two blocks of code.
@@ -605,16 +603,25 @@ bindings use sub-sections of this SRT.  The label is passed down to
 the nested bindings via the monad.
 
 \begin{code}
-getSRTInfo :: SRT -> FCode C_SRT
-getSRTInfo NoSRT        = return NoC_SRT
-getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel
-                             return (C_SRT srt_lbl off len)
+getSRTInfo :: Name -> SRT -> FCode C_SRT
+getSRTInfo id NoSRT = return NoC_SRT
+getSRTInfo id (SRT off len bmp)
+  | len > hALF_WORD || bmp == [fromIntegral srt_escape] = do 
+       srt_lbl <- getSRTLabel
+       let srt_desc_lbl = mkSRTDescLabel id
+       absC (CSRTDesc srt_desc_lbl srt_lbl off len bmp)
+       return (C_SRT srt_desc_lbl 0 srt_escape)
+  | otherwise = do
+       srt_lbl <- getSRTLabel
+       return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+
+srt_escape = (-1) :: StgHalfWord
 
 getSRTLabel :: FCode CLabel    -- Used only by cgPanic
 getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
                 return srt_lbl
 
-setSRTLabel :: CLabel -> Code -> Code
+setSRTLabel :: CLabel -> FCode a -> FCode a
 setSRTLabel srt_lbl code
   = do  MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
        withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)