[project @ 2003-12-10 14:15:16 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 faed478..d7a477b 100644 (file)
--- a/ghc/compiler/ghci/ByteCodeGen.lhs
+++ b/ghc/compiler/ghci/ByteCodeGen.lhs
@@ -19,7 +19,7 @@ import Name           ( Name, getName, mkSystemName )
 import Id
 import FiniteMap
 import ForeignCall     ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
 import Id
 import FiniteMap
 import ForeignCall     ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )

-import HscTypes                ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
+import HscTypes                ( TypeEnv, typeEnvTyCons, typeEnvClasses )

 import CoreUtils       ( exprType )
 import CoreSyn
 import PprCore         ( pprCoreExpr )
 import CoreUtils       ( exprType )
 import CoreSyn
 import PprCore         ( pprCoreExpr )

@@ -27,20 +27,19 @@ import Literal              ( Literal(..), literalPrimRep )
 import PrimRep
 import PrimOp          ( PrimOp(..) )
 import CoreFVs         ( freeVars )
 import PrimRep
 import PrimOp          ( PrimOp(..) )
 import CoreFVs         ( freeVars )

-import Type            ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, 
-                         isTyVarTy )
+import Type            ( typePrimRep, isUnLiftedType, splitTyConApp_maybe )

 import DataCon         ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, 
 import DataCon         ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, 

-                          dataConWrapId, isUnboxedTupleCon )
+                          isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
+                         dataConRepArity )

 import TyCon           ( tyConFamilySize, isDataTyCon, tyConDataCons,
 import TyCon           ( tyConFamilySize, isDataTyCon, tyConDataCons,

-                         isFunTyCon, isUnboxedTupleTyCon )
+                         isUnboxedTupleTyCon )

 import Class           ( Class, classTyCon )
 import Class           ( Class, classTyCon )

-import Type            ( Type, repType, splitFunTys, dropForAlls )
+import Type            ( Type, repType, splitFunTys, dropForAlls, pprType )

 import Util
 import DataCon         ( dataConRepArity )
 import Var             ( isTyVar )
 import VarSet          ( VarSet, varSetElems )
 import Util
 import DataCon         ( dataConRepArity )
 import Var             ( isTyVar )
 import VarSet          ( VarSet, varSetElems )

-import TysPrim         ( foreignObjPrimTyCon, 
-                         arrayPrimTyCon, mutableArrayPrimTyCon,
+import TysPrim         ( arrayPrimTyCon, mutableArrayPrimTyCon,

                          byteArrayPrimTyCon, mutableByteArrayPrimTyCon
                        )
 import PrimRep         ( isFollowableRep )
                          byteArrayPrimTyCon, mutableByteArrayPrimTyCon
                        )
 import PrimRep         ( isFollowableRep )

@@ -49,8 +48,8 @@ import ErrUtils               ( showPass, dumpIfSet_dyn )
 import Unique          ( mkPseudoUnique3 )
 import FastString      ( FastString(..), unpackFS )
 import Panic           ( GhcException(..) )
 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 OrdList
 import Constants       ( wORD_SIZE )
 

@@ -61,30 +60,27 @@ import Control.Exception    ( throwDyn )
 
 import GHC.Exts                ( Int(..), ByteArray# )
 
 
 import GHC.Exts                ( Int(..), ByteArray# )
 

-import Control.Monad   ( when, mapAndUnzipM )
-import Data.Char       ( ord )
-import Data.Bits
+import Control.Monad   ( when )
+import Data.Char       ( ord, chr )

 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module 
 
 byteCodeGen :: DynFlags
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module 
 
 byteCodeGen :: DynFlags

-            -> ModGuts
+            -> [CoreBind]
+           -> TypeEnv

             -> IO CompiledByteCode
             -> IO CompiledByteCode

-byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env })
+byteCodeGen dflags binds type_env

    = do showPass dflags "ByteCodeGen"
         let  local_tycons  = typeEnvTyCons  type_env
             local_classes = typeEnvClasses type_env
             tycs = local_tycons ++ map classTyCon local_classes
 
    = do showPass dflags "ByteCodeGen"
         let  local_tycons  = typeEnvTyCons  type_env
             local_classes = typeEnvClasses type_env
             tycs = local_tycons ++ map classTyCon local_classes
 

-        let flatBinds = concatMap getBind binds
-            getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
-            getBind (Rec binds)       = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
+        let flatBinds = [ (bndr, freeVars rhs) 
+                       | (bndr, rhs) <- flattenBinds binds]

 
         (BcM_State final_ctr mallocd, proto_bcos)
 
         (BcM_State final_ctr mallocd, proto_bcos)

-           <- runBc (BcM_State 0 []) (mapM (schemeR True []) flatBinds)
-                       --                               ^^
-                       -- better be no free vars in these top-level bindings
+           <- runBc (mapM schemeTopBind flatBinds)

 
         when (notNull mallocd)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
 
         when (notNull mallocd)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")

@@ -107,14 +103,11 @@ coreExprToBCOs dflags expr
 
       -- create a totally bogus name for the top-level BCO; this
       -- should be harmless, since it's never used for anything
 
       -- create a totally bogus name for the top-level BCO; this
       -- should be harmless, since it's never used for anything

-      let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel")
-          invented_id   = mkLocalId invented_name (panic "invented_id's type")
-         annexpr       = freeVars expr
-         fvs           = filter (not.isTyVar) (varSetElems (fst annexpr))
-
+      let invented_name  = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel")
+          invented_id    = mkLocalId invented_name (panic "invented_id's type")
+         

       (BcM_State final_ctr mallocd, proto_bco) 
       (BcM_State final_ctr mallocd, proto_bco) 

-         <- runBc (BcM_State 0 []) 
-                  (schemeR True fvs (invented_id, annexpr))
+         <- runBc (schemeTopBind (invented_id, freeVars expr))

 
       when (notNull mallocd)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
 
       when (notNull mallocd)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")

@@ -153,9 +146,11 @@ mkProtoBCO
    -> Int
    -> Int
    -> [StgWord]
    -> Int
    -> Int
    -> [StgWord]

+   -> Bool     -- True <=> is a return point, rather than a function

    -> [Ptr ()]
    -> ProtoBCO name
    -> [Ptr ()]
    -> ProtoBCO name

-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mallocd_blocks
+mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap
+  is_ret mallocd_blocks

    = ProtoBCO {
        protoBCOName = nm,
        protoBCOInstrs = maybe_with_stack_check,
    = ProtoBCO {
        protoBCOName = nm,
        protoBCOInstrs = maybe_with_stack_check,

@@ -174,16 +169,19 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap mallocd_blocks
         -- (hopefully rare) cases when the (overestimated) stack use
         -- exceeds iNTERP_STACK_CHECK_THRESH.
         maybe_with_stack_check
         -- (hopefully rare) cases when the (overestimated) stack use
         -- exceeds iNTERP_STACK_CHECK_THRESH.
         maybe_with_stack_check

+          | is_ret = peep_d
+               -- don't do stack checks at return points;
+               -- everything is aggregated up to the top BCO
+               -- (which must be a function)

            | stack_overest >= 65535
            = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" 
                       (int stack_overest)
            | stack_overest >= iNTERP_STACK_CHECK_THRESH
            | stack_overest >= 65535
            = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" 
                       (int stack_overest)
            | stack_overest >= iNTERP_STACK_CHECK_THRESH

-           = (STKCHECK stack_overest) : peep_d
+           = STKCHECK stack_overest : peep_d

            | otherwise
            = peep_d    -- the supposedly common case
              
         stack_overest = sum (map bciStackUse peep_d)
            | otherwise
            = peep_d    -- the supposedly common case
              
         stack_overest = sum (map bciStackUse peep_d)

-                        + 10 {- just to be really really sure -}

 
         -- Merge local pushes
         peep_d = peep (fromOL instrs_ordlist)
 
         -- Merge local pushes
         peep_d = peep (fromOL instrs_ordlist)

@@ -203,42 +201,48 @@ argBits (rep : args)
   | isFollowableRep rep = False : argBits args
   | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits 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
+
+-- Compile code for the right-hand side of a top-level binding
+
+schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
+
+
+schemeTopBind (id, rhs)
+  | Just data_con <- isDataConWorkId_maybe id,
+    isNullaryDataCon data_con
+  =    -- Special case for the worker of a nullary data con.
+       -- It'll look like this:        Nil = /\a -> Nil a
+       -- If we feed it into schemeR, we'll get 
+       --      Nil = Nil
+       -- because mkConAppCode treats nullary constructor applications
+       -- by just re-using the single top-level definition.  So
+       -- for the worker itself, we must allocate it directly.
+    emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+
+  | otherwise
+  = schemeR [{- No free variables -}] (id, rhs)

 
 -- -----------------------------------------------------------------------------
 -- schemeR
 
 
 -- -----------------------------------------------------------------------------
 -- schemeR
 

--- Compile code for the right hand side of a let binding.
+-- Compile code for a right-hand side, to give a BCO that,
+-- when executed with the free variables and arguments on top of the stack,
+-- will return with a pointer to the result on top of the stack, after
+-- removing the free variables and arguments.
+--

 -- Park the resulting BCO in the monad.  Also requires the
 -- variable to which this value was bound, so as to give the
 -- Park the resulting BCO in the monad.  Also requires the
 -- variable to which this value was bound, so as to give the

--- resulting BCO a name.  Bool indicates top-levelness.
-
-schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
-schemeR is_top fvs (nm, rhs) 
+-- resulting BCO a name. 
+
+schemeR :: [Id]                -- Free vars of the RHS, ordered as they
+                               -- will appear in the thunk.  Empty for
+                               -- top-level things, which have no free vars.
+       -> (Id, AnnExpr Id VarSet)
+       -> BcM (ProtoBCO Name)
+schemeR fvs (nm, rhs) 

 {-
    | trace (showSDoc (
               (char ' '
 {-
    | trace (showSDoc (
               (char ' '

@@ -247,30 +251,19 @@ schemeR is_top fvs (nm, rhs)
                $$ char ' '
               ))) False
    = undefined
                $$ char ' '
               ))) False
    = undefined

--}

    | otherwise
    | otherwise

-   = schemeR_wrk is_top fvs rhs nm (collect [] rhs)
-
-
-collect xs (_, AnnNote note e)
-   = collect xs e
-collect xs (_, AnnLam x e) 
-   = collect (if isTyVar x then xs else (x:xs)) e
-collect xs not_lambda
-   = (reverse xs, not_lambda)
+-}
+   = schemeR_wrk fvs nm rhs (collect [] rhs)

 
 

-schemeR_wrk is_top fvs original_body nm (args, body)
-   | Just dcon <- maybe_toplevel_null_con_rhs
-   = --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) $
-     ASSERT(null fvs)
-     emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
-                       (Right original_body) 0 0 [{-no bitmap-}])
+collect xs (_, AnnNote note e) = collect xs e
+collect xs (_, AnnLam x e)     = collect (if isTyVar x then xs else (x:xs)) e
+collect xs (_, not_lambda)     = (reverse xs, not_lambda)

 
 

-   | otherwise
+schemeR_wrk fvs nm original_body (args, body)

    = let 
         all_args  = reverse args ++ fvs
         arity     = length all_args
    = let 
         all_args  = reverse args ++ fvs
         arity     = length all_args

-        -- these are the args in reverse order.  We're compiling a function
+        -- all_args are the args in reverse order.  We're compiling a function

         -- \fv1..fvn x1..xn -> e 
         -- i.e. the fvs come first
 
         -- \fv1..fvn x1..xn -> e 
         -- i.e. the fvs come first
 

@@ -285,42 +278,37 @@ schemeR_wrk is_top fvs original_body nm (args, body)
      in
      schemeE szw_args 0 p_init body            `thenBc` \ body_code ->
      emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
      in
      schemeE szw_args 0 p_init body            `thenBc` \ body_code ->
      emitBc (mkProtoBCO (getName nm) body_code (Right original_body)

-               arity bitmap_size bitmap)
-
-     where
-        maybe_toplevel_null_con_rhs
-           | is_top && null args
-           = case nukeTyArgs (snd body) of
-                AnnVar v_wrk 
-                   -> case isDataConId_maybe v_wrk of
-                         Nothing -> Nothing
-                         Just dc_wrk |  nm == dataConWrapId dc_wrk
-                                     -> Just dc_wrk
-                                     |  otherwise 
-                                     -> Nothing
-                other -> Nothing
-           | otherwise
-           = Nothing
+               arity bitmap_size bitmap False{-not alts-})

 
 

-        nukeTyArgs (AnnApp f (_, AnnType _)) = nukeTyArgs (snd f)
-        nukeTyArgs other                     = other

 
 

+fvsToEnv :: BCEnv -> VarSet -> [Id]
+-- Takes the free variables of a right-hand side, and
+-- delivers an ordered list of the local variables that will
+-- be captured in the thunk for the RHS
+-- The BCEnv argument tells which variables are in the local
+-- environment: these are the ones that should be captured
+--
+-- The code that constructs the thunk, and the code that executes
+-- it, have to agree about this layout
+fvsToEnv p fvs = [v | v <- varSetElems fvs, 
+                     isId v,           -- Could be a type variable
+                     v `elemFM` p]

 
 -- -----------------------------------------------------------------------------
 -- schemeE
 
 -- Compile code to apply the given expression to the remaining args
 -- on the stack, returning a HNF.
 
 -- -----------------------------------------------------------------------------
 -- schemeE
 
 -- Compile code to apply the given expression to the remaining args
 -- on the stack, returning a HNF.

-schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList
+schemeE :: Int -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList

 
 -- Delegate tail-calls to schemeT.
 
 -- Delegate tail-calls to schemeT.

-schemeE d s p e@(fvs, AnnApp f a) 
-   = schemeT d s p (fvs, AnnApp f a)
+schemeE d s p e@(AnnApp f a) 
+   = schemeT d s p e

 
 

-schemeE d s p e@(fvs, AnnVar v)
+schemeE d s p e@(AnnVar v)

    | not (isUnLiftedType v_type)
    =  -- Lifted-type thing; push it in the normal way
    | not (isUnLiftedType v_type)
    =  -- Lifted-type thing; push it in the normal way

-     schemeT d s p (fvs, AnnVar v)
+     schemeT d s p e

 
    | otherwise
    = -- Returning an unlifted value.  
 
    | otherwise
    = -- Returning an unlifted value.  

@@ -333,7 +321,7 @@ schemeE d s p e@(fvs, AnnVar v)
       v_type = idType v
       v_rep = typePrimRep v_type
 
       v_type = idType v
       v_rep = typePrimRep v_type
 

-schemeE d s p (fvs, AnnLit literal)
+schemeE d s p (AnnLit literal)

    = pushAtom d p (AnnLit literal)     `thenBc` \ (push, szw) ->
      let l_rep = literalPrimRep literal
      in  returnBc (push                        -- value onto stack
    = pushAtom d p (AnnLit literal)     `thenBc` \ (push, szw) ->
      let l_rep = literalPrimRep literal
      in  returnBc (push                        -- value onto stack

@@ -341,100 +329,28 @@ schemeE d s p (fvs, AnnLit literal)
                    `snocOL` RETURN_UBX l_rep)  -- go
 
 
                    `snocOL` RETURN_UBX l_rep)  -- go
 
 

-#if 0
-{-
-   Disabled for now --SDM  (TODO: reinstate later, but do it better)
-
-   Deal specially with the cases
-      let x = fn atom1 .. atomn  in B
-   and
-      let x = Con atom1 .. atomn  in B
-              (Con must be saturated)
-
-   In these cases, generate code to allocate in-line.
-
-   This is optimisation of the general case for let, which follows
-   this one; this case can safely be omitted.  The reduction in
-   interpreter execution time seems to be around 5% for some programs,
-   with a similar drop in allocations.
-
-   This optimisation should be done more cleanly.  As-is, it is
-   inapplicable to RHSs in letrecs, and needlessly duplicates code in
-   schemeR and schemeT.  Some refactoring of the machinery would cure
-   both ills.  
--}
-schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b)
-   | ok_to_go
-   = let d_init = if is_con then d else d'
-     in
-     mkPushes d_init args_r_to_l_reordered     `thenBc` \ (d_final, push_code) ->
-     schemeE d' s p' b                         `thenBc` \ body_code ->
-     let size  = d_final - d_init
-         alloc = if is_con then nilOL else unitOL (ALLOC size)
-         pack  = unitOL (if is_con then PACK the_dcon size else MKAP size size)
-     in
-         returnBc (alloc `appOL` push_code `appOL` pack
-                   `appOL` body_code)
-     where
-        -- Decide whether we can do this or not
-        (ok_to_go, is_con, the_dcon, the_fn)
-            = case maybe_fn of
-                 Nothing        -> (False, bomb 1, bomb 2, bomb 3)
-                 Just (Left fn) -> (True,  False,  bomb 5, fn)
-                 Just (Right dcon)
-                    |  dataConRepArity dcon <= length args_r_to_l
-                    -> (True, True, dcon, bomb 6)
-                    |  otherwise
-                    -> (False, bomb 7, bomb 8, bomb 9)
-        bomb n = panic ("schemeE.is_con(hacky hack hack) " ++ show n)
-
-        -- Extract the args (R -> L) and fn
-        args_r_to_l_reordered
-           | not is_con
-           = args_r_to_l
-           | otherwise
-           = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
-             where isPtr = isFollowableRep . atomRep
-
-        args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
-        isTypeAtom (AnnType _) = True
-        isTypeAtom _           = False
-
-        (args_r_to_l_raw, maybe_fn) = chomp rhs
-        chomp expr
-           = case snd expr of
-                AnnVar v 
-                   |  isFCallId v || isPrimOpId v  
-                   -> ([], Nothing)
-                   |  otherwise
-                   -> case isDataConId_maybe v of
-                         Just dcon -> ([], Just (Right dcon))
-                         Nothing   -> ([], Just (Left v))
-                AnnApp f a  -> case chomp f of (az, f) -> (a:az, f)
-                AnnNote n e -> chomp e
-                other       -> ([], Nothing)
-
-        -- This is the env in which to translate the body
-        p' = addToFM p x d
-        d' = d + 1
-
-        -- Shove the args on the stack, including the fn in the non-dcon case
-        tag_when_push = not is_con
-
-#endif
+schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
+   | (AnnVar v, args_r_to_l) <- splitApp rhs,
+     Just data_con <- isDataConWorkId_maybe v,
+     dataConRepArity data_con == length args_r_to_l
+   =   -- Special case for a non-recursive let whose RHS is a 
+       -- saturatred constructor application.
+       -- Just allocate the constructor and carry on
+     mkConAppCode d s p data_con args_r_to_l   `thenBc` \ alloc_code ->
+     schemeE (d+1) s (addToFM p x d) body      `thenBc` \ body_code ->
+     returnBc (alloc_code `appOL` body_code)

 
 -- General case for let.  Generates correct, if inefficient, code in
 -- all situations.
 
 -- General case for let.  Generates correct, if inefficient, code in
 -- all situations.

-schemeE d s p (fvs, AnnLet binds b)
+schemeE d s p (AnnLet binds (_,body))

    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
          n_binds = length xs
 
    = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
          n_binds = length xs
 

-        is_local id = not (isTyVar id) && elemFM id p'
-         fvss  = map (filter is_local . varSetElems . fst) rhss
+         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
 
         -- the arity of each rhs
         arities = map (length . fst . collect []) rhss

@@ -450,7 +366,7 @@ schemeE d s p (fvs, AnnLet binds b)
          -- ToDo: don't build thunks for things with no free variables
          build_thunk dd [] size bco off
             = returnBc (PUSH_BCO bco
          -- 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
          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

@@ -461,7 +377,7 @@ schemeE d s p (fvs, AnnLet binds b)
                 mkAlloc sz arity = ALLOC_PAP arity sz
 
         compile_bind d' fvs x rhs size off = do
                 mkAlloc sz arity = ALLOC_PAP arity sz
 
         compile_bind d' fvs x rhs size off = do

-               bco <- schemeR False fvs (x,rhs)
+               bco <- schemeR fvs (x,rhs)

                build_thunk d' fvs size bco off
 
         compile_binds = 
                build_thunk d' fvs size bco off
 
         compile_binds = 

@@ -470,13 +386,13 @@ schemeE d s p (fvs, AnnLet binds b)
                zip5 fvss xs rhss sizes [n_binds, n_binds-1 .. 1]
            ]
      in do
                zip5 fvss xs rhss sizes [n_binds, n_binds-1 .. 1]
            ]
      in do

-     body_code <- schemeE d' s p' b
+     body_code <- schemeE d' s p' body

      thunk_codes <- sequence compile_binds
      returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
 
 
 
      thunk_codes <- sequence compile_binds
      returnBc (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
 
 
 

-schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
+schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])

    | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
        -- Convert 
        --      case .... of x { (# VoidRep'd-thing, a #) -> ... }
    | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
        -- Convert 
        --      case .... of x { (# VoidRep'd-thing, a #) -> ... }

@@ -494,7 +410,7 @@ schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
    = --trace "automagic mashing of case alts (# a, VoidRep #)" $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
    = --trace "automagic mashing of case alts (# a, VoidRep #)" $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 

-schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
+schemeE d s p (AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])

    | isUnboxedTupleCon dc
        -- Similarly, convert
        --      case .... of x { (# a #) -> ... }
    | isUnboxedTupleCon dc
        -- Similarly, convert
        --      case .... of x { (# a #) -> ... }

@@ -503,15 +419,15 @@ schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
    = --trace "automagic mashing of case alts (# a #)"  $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 
    = --trace "automagic mashing of case alts (# a #)"  $
      doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
 

-schemeE d s p (fvs, AnnCase scrut bndr alts)
+schemeE d s p (AnnCase scrut bndr alts)

    = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
 
    = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
 

-schemeE d s p (fvs, AnnNote note body)
+schemeE d s p (AnnNote note (_, body))

    = schemeE d s p body
 
 schemeE d s p other
    = pprPanic "ByteCodeGen.schemeE: unhandled case" 
    = schemeE d s p body
 
 schemeE d s p other
    = pprPanic "ByteCodeGen.schemeE: unhandled case" 

-               (pprCoreExpr (deAnnotate other))
+               (pprCoreExpr (deAnnotate' other))

 
 
 -- Compile code to do a tail call.  Specifically, push the fn,
 
 
 -- Compile code to do a tail call.  Specifically, push the fn,

@@ -523,27 +439,24 @@ schemeE d s p other
 --     The int will be on the stack.  Generate a code sequence
 --     to convert it to the relevant constructor, SLIDE and ENTER.
 --
 --     The int will be on the stack.  Generate a code sequence
 --     to convert it to the relevant constructor, SLIDE and ENTER.
 --

--- 1.  A nullary constructor.  Push its closure on the stack 
---     and SLIDE and RETURN.
+-- 1.  The fn denotes a ccall.  Defer to generateCCall.

 --
 -- 2.  (Another nasty hack).  Spot (# a::VoidRep, b #) and treat
 --     it simply as  b  -- since the representations are identical
 --     (the VoidRep takes up zero stack space).  Also, spot
 --     (# b #) and treat it as  b.
 --
 --
 -- 2.  (Another nasty hack).  Spot (# a::VoidRep, b #) and treat
 --     it simply as  b  -- since the representations are identical
 --     (the VoidRep takes up zero stack space).  Also, spot
 --     (# b #) and treat it as  b.
 --

--- 3.  The fn denotes a ccall.  Defer to generateCCall.
---
--- 4.  Application of a non-nullary constructor, by defn saturated.
+-- 3.  Application of a constructor, by defn saturated.

 --     Split the args into ptrs and non-ptrs, and push the nonptrs, 
 --     then the ptrs, and then do PACK and RETURN.
 --
 --     Split the args into ptrs and non-ptrs, and push the nonptrs, 
 --     then the ptrs, and then do PACK and RETURN.
 --

--- 5.  Otherwise, it must be a function call.  Push the args
+-- 4.  Otherwise, it must be a function call.  Push the args

 --     right to left, SLIDE and ENTER.
 
 schemeT :: Int                 -- Stack depth
         -> Sequel      -- Sequel depth
         -> BCEnv       -- stack env
 --     right to left, SLIDE and ENTER.
 
 schemeT :: Int                 -- Stack depth
         -> Sequel      -- Sequel depth
         -> BCEnv       -- stack env

-        -> AnnExpr Id VarSet 
+        -> AnnExpr' Id VarSet 

         -> BcM BCInstrList
 
 schemeT d s p app
         -> BcM BCInstrList
 
 schemeT d s p app

@@ -551,7 +464,7 @@ schemeT d s p app
 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
 --   = panic "schemeT ?!?!"
 
 --   | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
 --   = panic "schemeT ?!?!"
 

---   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
+--   | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False

 --   = error "?!?!" 
 
    -- Case 0
 --   = error "?!?!" 
 
    -- Case 0

@@ -563,28 +476,27 @@ schemeT d s p app
                     `snocOL` ENTER)
 
    -- Case 1
                     `snocOL` ENTER)
 
    -- Case 1

-   | Just con <- maybe_dcon, null args_r_to_l
-   = returnBc (
-        (PUSH_G (getName con) `consOL` mkSLIDE 1 (d-s))
-        `snocOL` ENTER
-     )
-
-   -- Case 3

    | Just (CCall ccall_spec) <- isFCallId_maybe fn
    = generateCCall d s p ccall_spec fn args_r_to_l
 
    | Just (CCall ccall_spec) <- isFCallId_maybe fn
    = generateCCall d s p ccall_spec fn args_r_to_l
 

-   -- Case 4: Constructor application
-   | Just con <- maybe_dcon
-   = if isUnboxedTupleCon con
-       then case args_r_to_l of
-               [arg1,arg2] | isVoidRepAtom arg1 -> 
-                  unboxedTupleReturn d s p arg2
-               [arg1,arg2] | isVoidRepAtom arg2 -> 
-                  unboxedTupleReturn d s p arg1
-               _other -> unboxedTupleException
-       else doConstructorApp d s p con args_r_to_l
-
-   -- Case 5: Tail call of function 
+   -- Case 2: Constructor application
+   | Just con <- maybe_saturated_dcon,
+     isUnboxedTupleCon con
+   = case args_r_to_l of
+       [arg1,arg2] | isVoidRepAtom arg1 -> 
+                 unboxedTupleReturn d s p arg2
+       [arg1,arg2] | isVoidRepAtom arg2 -> 
+                 unboxedTupleReturn d s p arg1
+       _other -> unboxedTupleException
+
+   -- Case 3: Ordinary data constructor
+   | Just con <- maybe_saturated_dcon
+   = mkConAppCode d s p con args_r_to_l        `thenBc` \ alloc_con ->
+     returnBc (alloc_con        `appOL` 
+               mkSLIDE 1 (d - s) `snocOL`
+               ENTER)
+
+   -- Case 4: Tail call of function 

    | otherwise
    = doTailCall d s p fn args_r_to_l
 
    | otherwise
    = doTailCall d s p fn args_r_to_l
 

@@ -592,64 +504,66 @@ schemeT d s p app
       -- Detect and extract relevant info for the tagToEnum kludge.
       maybe_is_tagToEnum_call
          = let extract_constr_Names ty
       -- 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
            case app of

-              (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
+              (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)

                  -> case isPrimOpId_maybe v of
                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
                       other            -> Nothing
               other -> Nothing
 
                  -> case isPrimOpId_maybe v of
                        Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
                       other            -> Nothing
               other -> Nothing
 

-      -- Extract the args (R->L) and fn
-      (args_r_to_l, fn) = chomp app
-      chomp expr
-         = case snd expr of
-              AnnVar v    -> ([], v)
-              AnnApp f (_,a)
-                | isTypeAtom a -> chomp f
-                | otherwise    -> case chomp f of (az, f) -> (a:az, f)
-              AnnNote n e -> chomp e
-              other       -> pprPanic "schemeT" 
-                               (ppr (deAnnotate (panic "schemeT.chomp", other)))
+       -- Extract the args (R->L) and fn
+       -- The function will necessarily be a variable, 
+       -- because we are compiling a tail call
+      (AnnVar fn, args_r_to_l) = splitApp app

 
 

-      n_args = length args_r_to_l
-
-      -- only consider this to be a constructor application iff it is
+      -- Only consider this to be a constructor application iff it is

       -- saturated.  Otherwise, we'll call the constructor wrapper.
       -- saturated.  Otherwise, we'll call the constructor wrapper.

-      maybe_dcon  = case isDataConId_maybe fn of
-                       Just con | dataConRepArity con == n_args -> Just con
-                       _ -> Nothing
+      n_args = length args_r_to_l
+      maybe_saturated_dcon  
+       = case isDataConWorkId_maybe fn of
+               Just con | dataConRepArity con == n_args -> Just con
+               _ -> Nothing

 
 -- -----------------------------------------------------------------------------
 
 -- -----------------------------------------------------------------------------

--- Generate code to build a constructor application and enter/return it.
-
-doConstructorApp
-       :: Int -> Sequel -> BCEnv
-       -> DataCon -> [AnnExpr' Id VarSet] -- args, in *reverse* order
-       -> BcM BCInstrList
-doConstructorApp d s p con args = do_pushery d con_args
+-- Generate code to build a constructor application, 
+-- leaving it on top of the stack
+
+mkConAppCode :: Int -> Sequel -> BCEnv
+            -> DataCon                 -- The data constructor
+            -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
+            -> BcM BCInstrList
+
+mkConAppCode orig_d s p con [] -- Nullary constructor
+  = ASSERT( isNullaryDataCon con )
+    returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
+       -- Instead of doing a PACK, which would allocate a fresh
+       -- copy of this constructor, use the single shared version.
+
+mkConAppCode orig_d s p con args_r_to_l 
+  = ASSERT( dataConRepArity con == length args_r_to_l )
+    do_pushery orig_d (non_ptr_args ++ ptr_args)

  where
        -- The args are already in reverse order, which is the way PACK
        -- expects them to be.  We must push the non-ptrs after the ptrs.
  where
        -- The args are already in reverse order, which is the way PACK
        -- expects them to be.  We must push the non-ptrs after the ptrs.

-      con_args = nptrs ++ ptrs
-           where (ptrs, nptrs) = partition isPtr args
-                isPtr = isFollowableRep . atomRep
-
-      narg_words = sum (map (getPrimRepSize.atomRep) con_args)
+      (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l

 
       do_pushery d (arg:args)
          = pushAtom d p arg                    `thenBc` \ (push, arg_words) ->
            do_pushery (d+arg_words) args       `thenBc` \ more_push_code ->
            returnBc (push `appOL` more_push_code)
       do_pushery d []
 
       do_pushery d (arg:args)
          = pushAtom d p arg                    `thenBc` \ (push, arg_words) ->
            do_pushery (d+arg_words) args       `thenBc` \ more_push_code ->
            returnBc (push `appOL` more_push_code)
       do_pushery d []

-         = returnBc ( (PACK con narg_words `consOL`
-                       mkSLIDE 1 (d - narg_words - s)) `snocOL`
-                       ENTER
-                     )
+         = returnBc (unitOL (PACK con n_arg_words))
+        where
+          n_arg_words = d - orig_d
+

 
 -- -----------------------------------------------------------------------------
 -- Returning an unboxed tuple with one non-void component (the only
 
 -- -----------------------------------------------------------------------------
 -- Returning an unboxed tuple with one non-void component (the only

@@ -733,7 +647,8 @@ doCase  :: Int -> Sequel -> BCEnv
        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
        -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
        -> BcM BCInstrList
        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
        -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
        -> BcM BCInstrList

-doCase d s p scrut bndr alts is_unboxed_tuple
+doCase d s p (_,scrut)
+ bndr alts is_unboxed_tuple

   = let
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.
   = let
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.

@@ -762,10 +677,10 @@ doCase d s p scrut bndr alts is_unboxed_tuple
         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
 
         -- given an alt, return a discr and code for it.
         isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple
 
         -- given an alt, return a discr and code for it.

-       codeALt alt@(DEFAULT, _, rhs)
+       codeALt alt@(DEFAULT, _, (_,rhs))

           = schemeE d_alts s p_alts rhs        `thenBc` \ rhs_code ->
             returnBc (NoDiscr, rhs_code)
           = schemeE d_alts s p_alts rhs        `thenBc` \ rhs_code ->
             returnBc (NoDiscr, rhs_code)

-        codeAlt alt@(discr, bndrs, rhs)
+        codeAlt alt@(discr, bndrs, (_,rhs))

           -- primitive or nullary constructor alt: no need to UNPACK
           | null real_bndrs = do
                rhs_code <- schemeE d_alts s p_alts rhs
           -- primitive or nullary constructor alt: no need to UNPACK
           | null real_bndrs = do
                rhs_code <- schemeE d_alts s p_alts rhs

@@ -799,7 +714,7 @@ doCase d s p scrut bndr alts is_unboxed_tuple
            = case l of MachInt i     -> DiscrI (fromInteger i)
                        MachFloat r   -> DiscrF (fromRational r)
                        MachDouble r  -> DiscrD (fromRational r)
            = case l of MachInt i     -> DiscrI (fromInteger i)
                        MachFloat r   -> DiscrF (fromRational r)
                        MachDouble r  -> DiscrD (fromRational r)

-                       MachChar i    -> DiscrI i
+                       MachChar i    -> DiscrI (ord i)

                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 
         maybe_ncons 
                        _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
 
         maybe_ncons 

@@ -816,7 +731,7 @@ doCase d s p scrut bndr alts is_unboxed_tuple
        -- things that are pointers, whereas in CgBindery the code builds the
        -- bitmap from the free slots and unboxed bindings.
        -- (ToDo: merge?)
        -- 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)
          where
          binds = fmToList p
          rel_slots = concat (map spread binds)

@@ -831,7 +746,7 @@ doCase d s p scrut bndr alts is_unboxed_tuple
      let 
          alt_bco_name = getName bndr
          alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
      let 
          alt_bco_name = getName bndr
          alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)

-                       0{-no arity-} d{-bitmap size-} bitmap
+                       0{-no arity-} d{-bitmap size-} bitmap True{-is alts-}

      -- in
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 --          "\n      bitmap = " ++ show bitmap) $ do
      -- in
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 --          "\n      bitmap = " ++ show bitmap) $ do

@@ -847,8 +762,8 @@ doCase d s p scrut bndr alts is_unboxed_tuple
 -- Deal with a CCall.
 
 -- Taggedly push the args onto the stack R->L,
 -- Deal with a CCall.
 
 -- Taggedly push the args onto the stack R->L,

--- deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
--- payloads in Ptr/Byte arrays).  Then, generate the marshalling
+-- deferencing ForeignObj#s and adjusting addrs to point to
+-- payloads in Ptr/Byte arrays.  Then, generate the marshalling

 -- (machine) code for the ccall, and create bytecodes to call that and
 -- then return in the right way.  
 
 -- (machine) code for the ccall, and create bytecodes to call that and
 -- then return in the right way.  
 

@@ -953,8 +868,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
          depth, and we RETURN.
 
          This arrangement makes it simple to do f-i-dynamic since the Addr#
          depth, and we RETURN.
 
          This arrangement makes it simple to do f-i-dynamic since the Addr#

-         value is the first arg anyway.  It also has the virtue that the
-         stack is GC-understandable at all times.
+         value is the first arg anyway.

 
          The marshalling code is generated specifically for this
          call site, and so knows exactly the (Haskell) stack
 
          The marshalling code is generated specifically for this
          call site, and so knows exactly the (Haskell) stack

@@ -972,8 +886,6 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
                  StaticTarget target
                     -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
                        returnBc (True, res)
                  StaticTarget target
                     -> ioToBc (lookupStaticPtr target) `thenBc` \res ->
                        returnBc (True, res)

-                 CasmTarget _
-                    -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)

      in
          get_target_info       `thenBc` \ (is_static, static_target_addr) ->
      let
      in
          get_target_info       `thenBc` \ (is_static, static_target_addr) ->
      let

@@ -1015,13 +927,9 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
          recordMallocBc addr_of_marshaller     `thenBc_`
      let
         -- Offset of the next stack frame down the stack.  The CCALL
          recordMallocBc addr_of_marshaller     `thenBc_`
      let
         -- Offset of the next stack frame down the stack.  The CCALL

-        -- instruction will temporarily shift the stack pointer up by
-        -- this much during the call, and shift it down again afterwards.
-        -- This is so that we don't have to worry about constructing
-        -- a bitmap to describe the stack layout of the call: the
-        -- contents of this part of the stack are irrelevant anyway,
-        -- it is only used to communicate the arguments to the
-        -- marshalling code.
+        -- instruction needs to describe the chunk of stack containing
+        -- the ccall args to the GC, so it needs to know how large it
+        -- is.  See comment in Interpreter.c with the CCALL instruction.

         stk_offset   = d_after_r - s
 
          -- do the call
         stk_offset   = d_after_r - s
 
          -- do the call

@@ -1042,7 +950,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
 mkDummyLiteral :: PrimRep -> Literal
 mkDummyLiteral pr
    = case pr of
 mkDummyLiteral :: PrimRep -> Literal
 mkDummyLiteral pr
    = case pr of

-        CharRep   -> MachChar 0
+        CharRep   -> MachChar (chr 0)

         IntRep    -> MachInt 0
         WordRep   -> MachWord 0
         DoubleRep -> MachDouble 0
         IntRep    -> MachInt 0
         WordRep   -> MachWord 0
         DoubleRep -> MachDouble 0

@@ -1148,8 +1056,8 @@ pushAtom d p (AnnVar v)
    | Just primop <- isPrimOpId_maybe v
    = returnBc (unitOL (PUSH_PRIMOP primop), 1)
 
    | Just primop <- isPrimOpId_maybe v
    = returnBc (unitOL (PUSH_PRIMOP primop), 1)
 

-   | otherwise
-   = let
+   | Just d_v <- lookupBCEnv_maybe p v  -- v is a local variable
+   = returnBc (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)

         -- d - d_v                 the number of words between the TOS 
         --                         and the 1st slot of the object
         --
         -- d - d_v                 the number of words between the TOS 
         --                         and the 1st slot of the object
         --

@@ -1160,30 +1068,24 @@ pushAtom d p (AnnVar v)
         --
         -- Having found the last slot, we proceed to copy the right number of
         -- slots on to the top of the stack.
         --
         -- Having found the last slot, we proceed to copy the right number of
         -- slots on to the top of the stack.

-        --
-         result
-            = case lookupBCEnv_maybe p v of
-                 Just d_v -> (toOL (nOfThem sz (PUSH_L (d-d_v+sz-2))), sz)
-                 Nothing  -> ASSERT(sz == 1) (unitOL (PUSH_G nm), sz)

 
 

-         nm = case isDataConId_maybe v of
-                 Just c  -> getName c
-                 Nothing -> getName v
+    | otherwise  -- v must be a global variable
+    = ASSERT(sz == 1) 
+      returnBc (unitOL (PUSH_G (getName v)), sz)

 
 

-         sz   = idSizeW v
-     in
-         returnBc result
+    where
+         sz = idSizeW v

 
 
 pushAtom d p (AnnLit lit)
    = case lit of
 
 
 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
      where
         code rep
            = let size_host_words = getPrimRepSize rep

@@ -1368,6 +1270,16 @@ unboxedTupleException
 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
 bind x f    = f x
 
 mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
 bind x f    = f x
 

+splitApp :: AnnExpr' id ann -> (AnnExpr' id ann, [AnnExpr' id ann])
+       -- The arguments are returned in *right-to-left* order
+splitApp (AnnApp (_,f) (_,a))
+              | isTypeAtom a = splitApp f
+              | otherwise    = case splitApp f of 
+                                    (f', as) -> (f', a:as)
+splitApp (AnnNote n (_,e))    = splitApp e
+splitApp e                   = (e, [])
+
+

 isTypeAtom :: AnnExpr' id ann -> Bool
 isTypeAtom (AnnType _) = True
 isTypeAtom _           = False
 isTypeAtom :: AnnExpr' id ann -> Bool
 isTypeAtom (AnnType _) = True
 isTypeAtom _           = False

@@ -1385,6 +1297,9 @@ atomRep (AnnApp f (_, AnnType _)) = atomRep (snd f)
 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 
 atomRep (AnnLam x e) | isTyVar x = atomRep (snd e)
 atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
 

+isPtrAtom :: AnnExpr' Id ann -> Bool
+isPtrAtom e = isFollowableRep (atomRep e)
+

 -- Let szsw be the sizes in words of some items pushed onto the stack,
 -- which has initial depth d'.  Return the values which the stack environment
 -- should map these items to.
 -- Let szsw be the sizes in words of some items pushed onto the stack,
 -- which has initial depth d'.  Return the values which the stack environment
 -- should map these items to.

@@ -1408,10 +1323,8 @@ ioToBc io = BcM $ \st -> do
   x <- io 
   return (st, x)
 
   x <- io 
   return (st, x)
 

-runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
-runBc st0 (BcM m) = do 
-  (st1, res) <- m st0
-  return (st1, res)
+runBc :: BcM r -> IO (BcM_State, r)
+runBc (BcM m) = m (BcM_State 0 []) 

 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do