[project @ 2003-06-13 09:27:13 by simonmar]

[ghc-hetmet.git] / ghc / compiler / ghci / ByteCodeGen.lhs

diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs
index 4ff021d..b5ce3fc 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -52,7 +52,8 @@ import Unique         ( mkPseudoUnique3 )
 import FastString      ( FastString(..), unpackFS )
 import Panic           ( GhcException(..) )
 import PprType         ( pprType )
-import SMRep           ( arrWordsHdrSize, arrPtrsHdrSize )
+import SMRep           ( arrWordsHdrSize, arrPtrsHdrSize, StgWord )
+import Bitmap          ( intsToReverseBitmap, mkBitmap )
 import OrdList
 import Constants       ( wORD_SIZE )
 import BasicTypes      ( TopLevelFlag(..), isTopLevel, isNotTopLevel )
@@ -206,32 +207,6 @@ argBits (rep : args)
   | isFollowableRep rep = False : argBits args
   | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
 
-mkBitmap :: [Bool] -> [StgWord]
-mkBitmap [] = []
-mkBitmap stuff = chunkToLiveness chunk : mkBitmap rest
-  where (chunk, rest) = splitAt wORD_SIZE_IN_BITS stuff
-
-chunkToLiveness :: [Bool] -> StgWord
-chunkToLiveness chunk = 
-  foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]
-
--- make a bitmap where the slots specified are the *zeros* in the bitmap.
--- eg. [1,2,4], size 4 ==> 0x8  (we leave any bits outside the size as zero,
--- just to make the bitmap easier to read).
-intsToBitmap :: Int -> [Int] -> [StgWord]
-intsToBitmap size slots{- must be sorted -}
-  | size <= 0 = []
-  | otherwise = 
-    (foldr xor init (map (1 `shiftL`) these)) : 
-       intsToBitmap (size - wORD_SIZE_IN_BITS) 
-            (map (\x -> x - wORD_SIZE_IN_BITS) rest)
-   where (these,rest) = span (<wORD_SIZE_IN_BITS) slots
-        init
-          | size >= wORD_SIZE_IN_BITS = complement 0
-          | otherwise                 = (1 `shiftL` size) - 1
-
-wORD_SIZE_IN_BITS = wORD_SIZE * 8 :: Int
-
 -- -----------------------------------------------------------------------------
 -- schemeTopBind
 
@@ -380,8 +355,8 @@ schemeE d s p (AnnLet binds (_,body))
 
          fvss  = map (fvsToEnv p' . fst) rhss
 
-         -- Sizes of free vars, + 1 for the fn
-         sizes = map (\rhs_fvs -> 1 + sum (map idSizeW rhs_fvs)) fvss
+         -- Sizes of free vars
+         sizes = map (\rhs_fvs -> sum (map idSizeW rhs_fvs)) fvss
 
         -- the arity of each rhs
         arities = map (length . fst . collect []) rhss
@@ -397,7 +372,7 @@ schemeE d s p (AnnLet binds (_,body))
          -- ToDo: don't build thunks for things with no free variables
          build_thunk dd [] size bco off
             = returnBc (PUSH_BCO bco
-                        `consOL` unitOL (MKAP (off+size-1) size))
+                        `consOL` unitOL (MKAP (off+size) size))
          build_thunk dd (fv:fvs) size bco off = do
               (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) 
               more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off
@@ -535,11 +510,14 @@ schemeT d s p app
       -- Detect and extract relevant info for the tagToEnum kludge.
       maybe_is_tagToEnum_call
          = let extract_constr_Names ty
-                  = case splitTyConApp_maybe (repType ty) of
-                       (Just (tyc, [])) |  isDataTyCon tyc
-                                        -> map getName (tyConDataCons tyc)
-                       other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
-           in 
+                | Just (tyc, []) <- splitTyConApp_maybe (repType ty),
+                  isDataTyCon tyc
+                  = map (getName . dataConWorkId) (tyConDataCons tyc)
+                  -- NOTE: use the worker name, not the source name of
+                  -- the DataCon.  See DataCon.lhs for details.
+                | otherwise
+                  = panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+           in
            case app of
               (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
                  -> case isPrimOpId_maybe v of
@@ -759,7 +737,7 @@ doCase d s p (_,scrut)
        -- things that are pointers, whereas in CgBindery the code builds the
        -- bitmap from the free slots and unboxed bindings.
        -- (ToDo: merge?)
-       bitmap = intsToBitmap d{-size-} (sortLt (<) rel_slots)
+       bitmap = intsToReverseBitmap d{-size-} (sortLt (<) rel_slots)
          where
          binds = fmToList p
          rel_slots = concat (map spread binds)
@@ -1109,13 +1087,13 @@ pushAtom d p (AnnVar v)
 
 pushAtom d p (AnnLit lit)
    = case lit of
-        MachLabel fs -> code CodePtrRep
-        MachWord w   -> code WordRep
-        MachInt i    -> code IntRep
-        MachFloat r  -> code FloatRep
-        MachDouble r -> code DoubleRep
-        MachChar c   -> code CharRep
-        MachStr s    -> pushStr s
+        MachLabel fs _ -> code CodePtrRep
+        MachWord w     -> code WordRep
+        MachInt i      -> code IntRep
+        MachFloat r    -> code FloatRep
+        MachDouble r   -> code DoubleRep
+        MachChar c     -> code CharRep
+        MachStr s      -> pushStr s
      where
         code rep
            = let size_host_words = getPrimRepSize rep