Remove the old codegen
authorSimon Marlow <marlowsd@gmail.com>
Sun, 14 Oct 2012 12:03:32 +0000 (13:03 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Fri, 19 Oct 2012 11:03:16 +0000 (12:03 +0100)
Except for CgUtils.fixStgRegisters that is used in the NCG and LLVM
backends, and should probably be moved somewhere else.

36 files changed:
compiler/cmm/CmmParse.y
compiler/cmm/OldCmm.hs
compiler/cmm/SMRep.lhs
compiler/codeGen/CgBindery.lhs [deleted file]
compiler/codeGen/CgBindery.lhs-boot [deleted file]
compiler/codeGen/CgCallConv.hs [deleted file]
compiler/codeGen/CgCase.lhs [deleted file]
compiler/codeGen/CgClosure.lhs [deleted file]
compiler/codeGen/CgCon.lhs [deleted file]
compiler/codeGen/CgExpr.lhs [deleted file]
compiler/codeGen/CgExpr.lhs-boot [deleted file]
compiler/codeGen/CgForeignCall.hs [deleted file]
compiler/codeGen/CgHeapery.lhs [deleted file]
compiler/codeGen/CgHpc.hs [deleted file]
compiler/codeGen/CgInfoTbls.hs [deleted file]
compiler/codeGen/CgLetNoEscape.lhs [deleted file]
compiler/codeGen/CgMonad.lhs [deleted file]
compiler/codeGen/CgParallel.hs [deleted file]
compiler/codeGen/CgPrimOp.hs [deleted file]
compiler/codeGen/CgProf.hs [deleted file]
compiler/codeGen/CgStackery.lhs [deleted file]
compiler/codeGen/CgTailCall.lhs [deleted file]
compiler/codeGen/CgTicky.hs [deleted file]
compiler/codeGen/CgUtils.hs
compiler/codeGen/ClosureInfo.lhs [deleted file]
compiler/codeGen/ClosureInfo.lhs-boot [deleted file]
compiler/codeGen/StgCmmGran.hs
compiler/codeGen/StgCmmLayout.hs
compiler/ghc.cabal.in
compiler/ghci/ByteCodeAsm.lhs
compiler/ghci/ByteCodeGen.lhs
compiler/ghci/ByteCodeInstr.lhs
compiler/ghci/ByteCodeItbls.lhs
compiler/ghci/DebuggerUtils.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs

index 46d1d72..c483502 100644 (file)
@@ -179,7 +179,7 @@ import StgCmmUtils
 import StgCmmForeign
 import StgCmmExpr
 import StgCmmClosure
-import StgCmmLayout
+import StgCmmLayout     hiding (ArgRep(..))
 import StgCmmTicky
 import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
 
index 3d0599b..cf05db9 100644 (file)
@@ -24,7 +24,7 @@ module OldCmm (
 
         module CmmExpr,
 
-        Section(..), ProfilingInfo(..), C_SRT(..)
+        Section(..), ProfilingInfo(..), New.C_SRT(..)
     ) where
 
 #include "HsVersions.h"
@@ -35,7 +35,6 @@ import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..),
              ProfilingInfo(..), ClosureTypeInfo(..) )
 
 import BlockId
-import ClosureInfo
 import CmmExpr
 import FastString
 import ForeignCall
@@ -184,7 +183,7 @@ type HintedCmmActual = CmmHinted CmmActual
 
 data CmmSafety
   = CmmUnsafe
-  | CmmSafe C_SRT
+  | CmmSafe New.C_SRT
   | CmmInterruptible
 
 -- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]'
index f39af7c..5f6f33e 100644 (file)
@@ -5,9 +5,6 @@
 
 Storage manager representation of closures
 
-This is here, rather than in ClosureInfo, just to keep nhc happy.
-Other modules should access this info through ClosureInfo.
-
 \begin{code}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs
deleted file mode 100644 (file)
index 834276b..0000000
+++ /dev/null
@@ -1,564 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgBindery]{Utility functions related to doing @CgBindings@}
-
-\begin{code}
-
-module CgBindery (
-        CgBindings, CgIdInfo,
-        StableLoc, VolatileLoc,
-
-        cgIdInfoId, cgIdInfoArgRep, cgIdInfoLF,
-
-        stableIdInfo, heapIdInfo,
-        taggedStableIdInfo, taggedHeapIdInfo,
-        letNoEscapeIdInfo, idInfoToAmode,
-
-        addBindC, addBindsC,
-
-        nukeVolatileBinds,
-        nukeDeadBindings,
-        getLiveStackSlots,
-        getLiveStackBindings,
-
-        bindArgsToStack,  rebindToStack,
-        bindNewToNode, bindNewToUntagNode, bindNewToReg, bindArgsToRegs,
-        bindNewToTemp,
-        getArgAmode, getArgAmodes, 
-        getCgIdInfo, 
-        getCAddrModeIfVolatile, getVolatileRegs,
-        maybeLetNoEscape, 
-    ) where
-
-import CgMonad
-import CgHeapery
-import CgStackery
-import CgUtils
-import CLabel
-import ClosureInfo
-
-import DynFlags
-import OldCmm
-import PprCmm           ( {- instance Outputable -} )
-import SMRep
-import Id
-import DataCon
-import VarEnv
-import VarSet
-import Literal
-import Maybes
-import Name
-import StgSyn
-import Unique
-import UniqSet
-import Outputable
-import FastString
-
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[Bindery-datatypes]{Data types}
-%*                                                                      *
-%************************************************************************
-
-@(CgBinding a b)@ is a type of finite maps from a to b.
-
-The assumption used to be that @lookupCgBind@ must get exactly one
-match. This is {\em completely wrong} in the case of compiling
-letrecs (where knot-tying is used). An initial binding is fed in (and
-never evaluated); eventually, a correct binding is put into the
-environment. So there can be two bindings for a given name.
-
-\begin{code}
-type CgBindings = IdEnv CgIdInfo
-
-data CgIdInfo
-  = CgIdInfo    
-        { cg_id :: Id   -- Id that this is the info for
-                        -- Can differ from the Id at occurrence sites by 
-                        -- virtue of being externalised, for splittable C
-        , cg_rep :: CgRep
-        , cg_vol :: VolatileLoc
-        , cg_stb :: StableLoc
-        , cg_lf  :: LambdaFormInfo 
-        , cg_tag :: {-# UNPACK #-} !Int  -- tag to be added in idInfoToAmode
-         }
-
-mkCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> CgIdInfo
-mkCgIdInfo dflags id vol stb lf
-  = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, 
-               cg_lf = lf, cg_rep = idCgRep id, cg_tag = tag }
-  where
-    tag
-      | Just con <- isDataConWorkId_maybe id,
-          {- Is this an identifier for a static constructor closure? -}
-        isNullaryRepDataCon con
-          {- If yes, is this a nullary constructor?
-             If yes, we assume that the constructor is evaluated and can
-             be tagged.
-           -}
-      = tagForCon dflags con
-
-      | otherwise
-      = funTagLFInfo dflags lf
-
-voidIdInfo :: Id -> CgIdInfo
-voidIdInfo id = CgIdInfo { cg_id = id, cg_vol = NoVolatileLoc
-                         , cg_stb = VoidLoc, cg_lf = mkLFArgument id
-                         , cg_rep = VoidArg, cg_tag = 0 }
-        -- Used just for VoidRep things
-
-data VolatileLoc        -- These locations die across a call
-  = NoVolatileLoc
-  | RegLoc      CmmReg             -- In one of the registers (global or local)
-  | VirHpLoc    VirtualHpOffset  -- Hp+offset (address of closure)
-  | VirNodeLoc  ByteOff            -- Cts of offset indirect from Node
-                                   -- ie *(Node+offset).
-                                   -- NB. Byte offset, because we subtract R1's
-                                   -- tag from the offset.
-
-mkTaggedCgIdInfo :: DynFlags -> Id -> VolatileLoc -> StableLoc -> LambdaFormInfo -> DataCon
-                 -> CgIdInfo
-mkTaggedCgIdInfo dflags id vol stb lf con
-  = CgIdInfo { cg_id = id, cg_vol = vol, cg_stb = stb, 
-               cg_lf = lf, cg_rep = idCgRep id, cg_tag = tagForCon dflags con }
-\end{code}
-
-@StableLoc@ encodes where an Id can be found, used by
-the @CgBindings@ environment in @CgBindery@.
-
-\begin{code}
-data StableLoc
-  = NoStableLoc
-
-  | VirStkLoc   VirtualSpOffset         -- The thing is held in this
-                                        -- stack slot
-
-  | VirStkLNE   VirtualSpOffset         -- A let-no-escape thing; the
-                                        -- value is this stack pointer
-                                        -- (as opposed to the contents of the slot)
-
-  | StableLoc   CmmExpr
-  | VoidLoc     -- Used only for VoidRep variables.  They never need to
-                -- be saved, so it makes sense to treat treat them as
-                -- having a stable location
-
-instance Outputable CgIdInfo where
-  ppr (CgIdInfo id _ vol stb _ _)
-    -- TODO, pretty pring the tag info
-    = ppr id <+> ptext (sLit "-->") <+> vcat [ppr vol, ppr stb]
-
-instance Outputable VolatileLoc where
-  ppr NoVolatileLoc = empty
-  ppr (RegLoc r)     = ptext (sLit "reg") <+> ppr r
-  ppr (VirHpLoc v)   = ptext (sLit "vh")  <+> ppr v
-  ppr (VirNodeLoc v) = ptext (sLit "vn")  <+> ppr v
-
-instance Outputable StableLoc where
-  ppr NoStableLoc   = empty
-  ppr VoidLoc       = ptext (sLit "void")
-  ppr (VirStkLoc v) = ptext (sLit "vs")    <+> ppr v
-  ppr (VirStkLNE v) = ptext (sLit "lne")   <+> ppr v
-  ppr (StableLoc a) = ptext (sLit "amode") <+> ppr a
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[Bindery-idInfo]{Manipulating IdInfo}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-stableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> CgIdInfo
-stableIdInfo dflags id amode lf_info = mkCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info
-
-heapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> CgIdInfo
-heapIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info
-
-letNoEscapeIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
-letNoEscapeIdInfo dflags id sp lf_info
-    = mkCgIdInfo dflags id NoVolatileLoc (VirStkLNE sp) lf_info
-
-stackIdInfo :: DynFlags -> Id -> VirtualSpOffset -> LambdaFormInfo -> CgIdInfo
-stackIdInfo dflags id sp lf_info
-    = mkCgIdInfo dflags id NoVolatileLoc (VirStkLoc sp) lf_info
-
-nodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> CgIdInfo
-nodeIdInfo dflags id offset lf_info = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset)) NoStableLoc lf_info
-
-regIdInfo :: DynFlags -> Id -> CmmReg -> LambdaFormInfo -> CgIdInfo
-regIdInfo dflags id reg lf_info = mkCgIdInfo dflags id (RegLoc reg) NoStableLoc lf_info
-
-taggedStableIdInfo :: DynFlags -> Id -> CmmExpr -> LambdaFormInfo -> DataCon -> CgIdInfo
-taggedStableIdInfo dflags id amode lf_info con
-  = mkTaggedCgIdInfo dflags id NoVolatileLoc (StableLoc amode) lf_info con
-
-taggedHeapIdInfo :: DynFlags -> Id -> VirtualHpOffset -> LambdaFormInfo -> DataCon
-                 -> CgIdInfo
-taggedHeapIdInfo dflags id offset lf_info con
-  = mkTaggedCgIdInfo dflags id (VirHpLoc offset) NoStableLoc lf_info con
-
-untagNodeIdInfo :: DynFlags -> Id -> Int -> LambdaFormInfo -> Int -> CgIdInfo
-untagNodeIdInfo dflags id offset lf_info tag
-  = mkCgIdInfo dflags id (VirNodeLoc (wORD_SIZE dflags * offset - tag)) NoStableLoc lf_info
-
-
-idInfoToAmode :: CgIdInfo -> FCode CmmExpr
-idInfoToAmode info = do
-    dflags <- getDynFlags
-    let mach_rep = argMachRep dflags (cg_rep info)
-
-        maybeTag amode  -- add the tag, if we have one
-          | tag == 0   = amode
-          | otherwise  = cmmOffsetB dflags amode tag
-          where tag = cg_tag info
-    case cg_vol info of {
-      RegLoc reg        -> returnFC (CmmReg reg) ;
-      VirNodeLoc nd_off -> returnFC (CmmLoad (cmmOffsetB dflags (CmmReg nodeReg) nd_off)
-                                             mach_rep) ;
-      VirHpLoc hp_off   -> do { off <- getHpRelOffset hp_off
-                              ; return $! maybeTag off };
-      NoVolatileLoc -> 
-
-    case cg_stb info of
-      StableLoc amode  -> returnFC $! maybeTag amode
-      VirStkLoc sp_off -> do { sp_rel <- getSpRelOffset sp_off
-                             ; return (CmmLoad sp_rel mach_rep) }
-
-      VirStkLNE sp_off -> getSpRelOffset sp_off
-
-      VoidLoc -> return $ pprPanic "idInfoToAmode: void" (ppr (cg_id info))
-                -- We return a 'bottom' amode, rather than panicing now
-                -- In this way getArgAmode returns a pair of (VoidArg, bottom)
-                -- and that's exactly what we want
-
-      NoStableLoc -> pprPanic "idInfoToAmode: no loc" (ppr (cg_id info))
-    }
-
-cgIdInfoId :: CgIdInfo -> Id
-cgIdInfoId = cg_id 
-
-cgIdInfoLF :: CgIdInfo -> LambdaFormInfo
-cgIdInfoLF = cg_lf
-
-cgIdInfoArgRep :: CgIdInfo -> CgRep
-cgIdInfoArgRep = cg_rep
-
-maybeLetNoEscape :: CgIdInfo -> Maybe VirtualSpOffset
-maybeLetNoEscape (CgIdInfo { cg_stb = VirStkLNE sp_off }) = Just sp_off
-maybeLetNoEscape _                                        = Nothing
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgMonad-bindery]{Monad things for fiddling with @CgBindings@}
-%*                                                                      *
-%************************************************************************
-
-There are three basic routines, for adding (@addBindC@), modifying
-(@modifyBindC@) and looking up (@getCgIdInfo@) bindings.
-
-A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
-The name should not already be bound. (nice ASSERT, eh?)
-
-\begin{code}
-addBindC :: Id -> CgIdInfo -> Code
-addBindC name stuff_to_bind = do
-        binds <- getBinds
-        setBinds $ extendVarEnv binds name stuff_to_bind
-
-addBindsC :: [(Id, CgIdInfo)] -> Code
-addBindsC new_bindings = do
-        binds <- getBinds
-        let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info)
-                              binds
-                              new_bindings
-        setBinds new_binds
-
-modifyBindC :: Id -> (CgIdInfo -> CgIdInfo) -> Code
-modifyBindC name mangle_fn = do
-        binds <- getBinds
-        setBinds $ modifyVarEnv mangle_fn binds name
-
-getCgIdInfo :: Id -> FCode CgIdInfo
-getCgIdInfo id
-  = do  { dflags <- getDynFlags
-        ; -- Try local bindings first
-        ; local_binds  <- getBinds
-        ; case lookupVarEnv local_binds id of {
-            Just info -> return info ;
-            Nothing   -> do
-
-        {       -- Try top-level bindings
-          static_binds <- getStaticBinds
-        ; case lookupVarEnv static_binds id of {
-            Just info -> return info ;
-            Nothing   ->
-
-                -- Should be imported; make up a CgIdInfo for it
-        let 
-            name = idName id
-        in
-        if isExternalName name then do
-            let ext_lbl = CmmLit (CmmLabel (mkClosureLabel name $ idCafInfo id))
-            return (stableIdInfo dflags id ext_lbl (mkLFImported id))
-        else
-        if isVoidArg (idCgRep id) then
-                -- Void things are never in the environment
-            return (voidIdInfo id)
-        else
-        -- Bug  
-        cgLookupPanic id
-        }}}}
-    
-                        
-cgLookupPanic :: Id -> FCode a
-cgLookupPanic id
-  = do  static_binds <- getStaticBinds
-        local_binds <- getBinds
---      srt <- getSRTLabel
-        pprPanic "cgLookupPanic (probably invalid Core; try -dcore-lint)"
-                (vcat [ppr id,
-                ptext (sLit "static binds for:"),
-                vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ],
-                ptext (sLit "local binds for:"),
-                vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ]
---              ptext (sLit "SRT label") <+> pprCLabel srt
-              ])
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[Bindery-nuke-volatile]{Nuking volatile bindings}
-%*                                                                      *
-%************************************************************************
-
-We sometimes want to nuke all the volatile bindings; we must be sure
-we don't leave any (NoVolatile, NoStable) binds around...
-
-\begin{code}
-nukeVolatileBinds :: CgBindings -> CgBindings
-nukeVolatileBinds binds
-  = mkVarEnv (foldr keep_if_stable [] (varEnvElts binds))
-  where
-    keep_if_stable (CgIdInfo { cg_stb = NoStableLoc }) acc = acc
-    keep_if_stable info acc
-      = (cg_id info, info { cg_vol = NoVolatileLoc }) : acc
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection[lookup-interface]{Interface functions to looking up bindings}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-getCAddrModeIfVolatile :: Id -> FCode (Maybe CmmExpr)
-getCAddrModeIfVolatile id
-  = do  { info <- getCgIdInfo id
-        ; case cg_stb info of
-                NoStableLoc -> do -- Aha!  So it is volatile!
-                        amode <- idInfoToAmode info
-                        return $ Just amode
-                _ -> return Nothing }
-\end{code}
-
-@getVolatileRegs@ gets a set of live variables, and returns a list of
-all registers on which these variables depend. These are the regs
-which must be saved and restored across any C calls. If a variable is
-both in a volatile location (depending on a register) {\em and} a
-stable one (notably, on the stack), we modify the current bindings to
-forget the volatile one.
-
-\begin{code}
-getVolatileRegs :: StgLiveVars -> FCode [GlobalReg]
-getVolatileRegs vars = do
-  do    { stuff <- mapFCs snaffle_it (varSetElems vars)
-        ; returnFC $ catMaybes stuff }
-  where
-    snaffle_it var = do
-        { info <- getCgIdInfo var 
-        ; let
-                -- commoned-up code...
-             consider_reg reg
-                =       -- We assume that all regs can die across C calls
-                        -- We leave it to the save-macros to decide which
-                        -- regs *really* need to be saved.
-                  case cg_stb info of
-                        NoStableLoc     -> returnFC (Just reg) -- got one!
-                        _ -> do
-                                { -- has both volatile & stable locations;
-                                  -- force it to rely on the stable location
-                                  modifyBindC var nuke_vol_bind 
-                                ; return Nothing }
-
-        ; case cg_vol info of
-            RegLoc (CmmGlobal reg) -> consider_reg reg
-            VirNodeLoc _           -> consider_reg node
-            _                      -> returnFC Nothing  -- Local registers
-        }
-
-    nuke_vol_bind info = info { cg_vol = NoVolatileLoc }
-
-getArgAmode :: StgArg -> FCode (CgRep, CmmExpr)
-getArgAmode (StgVarArg var) 
-  = do  { info <- getCgIdInfo var
-        ; amode <- idInfoToAmode info
-        ; return (cgIdInfoArgRep info, amode ) }
-
-getArgAmode (StgLitArg lit) 
-  = do  { cmm_lit <- cgLit lit
-        ; return (typeCgRep (literalType lit), CmmLit cmm_lit) }
-
-getArgAmodes :: [StgArg] -> FCode [(CgRep, CmmExpr)]
-getArgAmodes [] = returnFC []
-getArgAmodes (atom:atoms)
-  = do { amode  <- getArgAmode  atom 
-       ; amodes <- getArgAmodes atoms
-       ; return ( amode : amodes ) }
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[binding-and-rebinding-interface]{Interface functions for binding and re-binding names}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-bindArgsToStack :: [(Id, VirtualSpOffset)] -> Code
-bindArgsToStack args
-  = do dflags <- getDynFlags
-       let bind (id, offset) = addBindC id (stackIdInfo dflags id offset (mkLFArgument id))
-       mapCs bind args
-
-bindArgsToRegs :: [(Id, GlobalReg)] -> Code
-bindArgsToRegs args
-  = mapCs bind args
-  where
-    bind (arg, reg) = bindNewToReg arg (CmmGlobal reg) (mkLFArgument arg)
-
-bindNewToNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Code
-bindNewToNode id offset lf_info
-  = do dflags <- getDynFlags
-       addBindC id (nodeIdInfo dflags id offset lf_info)
-
-bindNewToUntagNode :: Id -> VirtualHpOffset -> LambdaFormInfo -> Int -> Code
-bindNewToUntagNode id offset lf_info tag
-  = do dflags <- getDynFlags
-       addBindC id (untagNodeIdInfo dflags id offset lf_info tag)
-
--- Create a new temporary whose unique is that in the id,
--- bind the id to it, and return the addressing mode for the
--- temporary.
-bindNewToTemp :: Id -> FCode LocalReg
-bindNewToTemp id
-  = do  dflags <- getDynFlags
-        let uniq     = getUnique id
-            temp_reg = LocalReg uniq (argMachRep dflags (idCgRep id))
-            lf_info  = mkLFArgument id  -- Always used of things we
-                                        -- know nothing about
-        addBindC id (regIdInfo dflags id (CmmLocal temp_reg) lf_info)
-        return temp_reg
-
-bindNewToReg :: Id -> CmmReg -> LambdaFormInfo -> Code
-bindNewToReg name reg lf_info
-  = do dflags <- getDynFlags
-       let info = mkCgIdInfo dflags name (RegLoc reg) NoStableLoc lf_info
-       addBindC name info
-
-rebindToStack :: Id -> VirtualSpOffset -> Code
-rebindToStack name offset
-  = modifyBindC name replace_stable_fn
-  where
-    replace_stable_fn info = info { cg_stb = VirStkLoc offset }
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgMonad-deadslots]{Finding dead stack slots}
-%*                                                                      *
-%************************************************************************
-
-nukeDeadBindings does the following:
-
-      - Removes all bindings from the environment other than those
-        for variables in the argument to nukeDeadBindings.
-      - Collects any stack slots so freed, and returns them to the  stack free
-        list.
-      - Moves the virtual stack pointer to point to the topmost used
-        stack locations.
-
-You can have multi-word slots on the stack (where a Double# used to
-be, for instance); if dead, such a slot will be reported as *several*
-offsets (one per word).
-
-Probably *naughty* to look inside monad...
-
-\begin{code}
-nukeDeadBindings :: StgLiveVars  -- All the *live* variables
-                 -> Code
-nukeDeadBindings live_vars = do
-        dflags <- getDynFlags
-        binds <- getBinds
-        let (dead_stk_slots, bs') =
-                dead_slots dflags live_vars
-                        [] []
-                        [ (cg_id b, b) | b <- varEnvElts binds ]
-        setBinds $ mkVarEnv bs'
-        freeStackSlots dead_stk_slots
-\end{code}
-
-Several boring auxiliary functions to do the dirty work.
-
-\begin{code}
-dead_slots :: DynFlags
-           -> StgLiveVars
-           -> [(Id,CgIdInfo)]
-           -> [VirtualSpOffset]
-           -> [(Id,CgIdInfo)]
-           -> ([VirtualSpOffset], [(Id,CgIdInfo)])
-
--- dead_slots carries accumulating parameters for
---      filtered bindings, dead slots
-dead_slots _ _ fbs ds []
-  = (ds, reverse fbs) -- Finished; rm the dups, if any
-
-dead_slots dflags live_vars fbs ds ((v,i):bs)
-  | v `elementOfUniqSet` live_vars
-    = dead_slots dflags live_vars ((v,i):fbs) ds bs
-          -- Live, so don't record it in dead slots
-          -- Instead keep it in the filtered bindings
-
-  | otherwise
-    = case cg_stb i of
-        VirStkLoc offset
-         | size > 0
-         -> dead_slots dflags live_vars fbs ([offset-size+1 .. offset] ++ ds) bs
-
-        _ -> dead_slots dflags live_vars fbs ds bs
-  where
-    size :: WordOff
-    size = cgRepSizeW dflags (cg_rep i)
-
-getLiveStackSlots :: FCode [VirtualSpOffset]
--- Return the offsets of slots in stack containig live pointers
-getLiveStackSlots 
-  = do  { binds <- getBinds
-        ; return [off | CgIdInfo { cg_stb = VirStkLoc off, 
-                                   cg_rep = rep } <- varEnvElts binds, 
-                        isFollowableArg rep] }
-
-getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
-getLiveStackBindings
-  = do { binds <- getBinds
-       ; return [(off, bind) |
-                 bind <- varEnvElts binds,
-                 CgIdInfo { cg_stb = VirStkLoc off,
-                            cg_rep = rep} <- [bind],
-                 isFollowableArg rep] }
-\end{code}
-
diff --git a/compiler/codeGen/CgBindery.lhs-boot b/compiler/codeGen/CgBindery.lhs-boot
deleted file mode 100644 (file)
index e504a6a..0000000
+++ /dev/null
@@ -1,11 +0,0 @@
-\begin{code}
-module CgBindery where
-import VarEnv( IdEnv )
-
-data CgIdInfo
-data VolatileLoc
-data StableLoc
-type CgBindings = IdEnv CgIdInfo
-
-nukeVolatileBinds :: CgBindings -> CgBindings
-\end{code}
\ No newline at end of file
diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
deleted file mode 100644 (file)
index e4095fd..0000000
+++ /dev/null
@@ -1,414 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2004-2006
---
--- CgCallConv
---
--- The datatypes and functions here encapsulate the
--- calling and return conventions used by the code generator.
---
------------------------------------------------------------------------------
-
-module CgCallConv (
-        -- Argument descriptors
-        mkArgDescr,
-
-        -- Liveness
-        mkRegLiveness,
-
-        -- Register assignment
-        assignCallRegs, assignReturnRegs, assignPrimOpCallRegs,
-
-        -- Calls
-        constructSlowCall, slowArgs, slowCallPattern,
-
-        -- Returns
-        dataReturnConvPrim,
-        getSequelAmode
-    ) where
-
-import CgMonad
-import CgProf
-import SMRep
-
-import OldCmm
-import CLabel
-
-import CgStackery
-import ClosureInfo( CgRep(..), nonVoidArg, idCgRep, cgRepSizeW, isFollowableArg )
-import OldCmmUtils
-import Maybes
-import Id
-import Name
-import Util
-import DynFlags
-import Module
-import FastString
-import Outputable
-import Platform
-import Data.Bits
-
--------------------------------------------------------------------------
---
---      Making argument descriptors
---
---  An argument descriptor describes the layout of args on the stack,
---  both for    * GC (stack-layout) purposes, and
---              * saving/restoring registers when a heap-check fails
---
--- Void arguments aren't important, therefore (contrast constructSlowCall)
---
--------------------------------------------------------------------------
-
--- bring in ARG_P, ARG_N, etc.
-#include "../includes/rts/storage/FunTypes.h"
-
--------------------------
-mkArgDescr :: Name -> [Id] -> FCode ArgDescr
-mkArgDescr _nm args
-  = do dflags <- getDynFlags
-       let arg_bits = argBits dflags arg_reps
-           arg_reps = filter nonVoidArg (map idCgRep args)
-           -- Getting rid of voids eases matching of standard patterns
-       case stdPattern arg_reps of
-           Just spec_id -> return (ArgSpec spec_id)
-           Nothing      -> return (ArgGen arg_bits)
-
-argBits :: DynFlags -> [CgRep] -> [Bool]    -- True for non-ptr, False for ptr
-argBits _      []              = []
-argBits dflags (PtrArg : args) = False : argBits dflags args
-argBits dflags (arg    : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args
-
-stdPattern :: [CgRep] -> Maybe Int
-stdPattern reps
-    = case reps of
-      []          -> Just ARG_NONE  -- just void args, probably
-
-      [PtrArg]    -> Just ARG_P
-      [FloatArg]  -> Just ARG_F
-      [DoubleArg] -> Just ARG_D
-      [LongArg]   -> Just ARG_L
-      [NonPtrArg] -> Just ARG_N
-
-      [NonPtrArg,NonPtrArg] -> Just ARG_NN
-      [NonPtrArg,PtrArg]    -> Just ARG_NP
-      [PtrArg,NonPtrArg]    -> Just ARG_PN
-      [PtrArg,PtrArg]       -> Just ARG_PP
-
-      [NonPtrArg,NonPtrArg,NonPtrArg] -> Just ARG_NNN
-      [NonPtrArg,NonPtrArg,PtrArg]    -> Just ARG_NNP
-      [NonPtrArg,PtrArg,NonPtrArg]    -> Just ARG_NPN
-      [NonPtrArg,PtrArg,PtrArg]       -> Just ARG_NPP
-      [PtrArg,NonPtrArg,NonPtrArg]    -> Just ARG_PNN
-      [PtrArg,NonPtrArg,PtrArg]       -> Just ARG_PNP
-      [PtrArg,PtrArg,NonPtrArg]       -> Just ARG_PPN
-      [PtrArg,PtrArg,PtrArg]          -> Just ARG_PPP
-
-      [PtrArg,PtrArg,PtrArg,PtrArg]               -> Just ARG_PPPP
-      [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg]        -> Just ARG_PPPPP
-      [PtrArg,PtrArg,PtrArg,PtrArg,PtrArg,PtrArg] -> Just ARG_PPPPPP
-      _ -> Nothing
-
-
--------------------------------------------------------------------------
---
---              Bitmap describing register liveness
---              across GC when doing a "generic" heap check
---              (a RET_DYN stack frame).
---
--- NB. Must agree with these macros (currently in StgMacros.h):
--- GET_NON_PTRS(), GET_PTRS(), GET_LIVENESS().
--------------------------------------------------------------------------
-
-mkRegLiveness :: DynFlags -> [(Id, GlobalReg)] -> Int -> Int -> StgWord
-mkRegLiveness dflags regs ptrs nptrs
-  = (toStgWord dflags (toInteger nptrs) `shiftL` 16) .|.
-    (toStgWord dflags (toInteger ptrs)  `shiftL` 24) .|.
-    all_non_ptrs `xor` toStgWord dflags (reg_bits regs)
-  where
-    all_non_ptrs = toStgWord dflags 0xff
-
-    reg_bits [] = 0
-    reg_bits ((id, VanillaReg i _) : regs) | isFollowableArg (idCgRep id)
-        = (1 `shiftL` (i - 1)) .|. reg_bits regs
-    reg_bits (_ : regs)
-        = reg_bits regs
-
--------------------------------------------------------------------------
---
---              Pushing the arguments for a slow call
---
--------------------------------------------------------------------------
-
--- For a slow call, we must take a bunch of arguments and intersperse
--- some stg_ap_<pattern>_ret_info return addresses.
-constructSlowCall
-        :: [(CgRep,CmmExpr)]
-        -> (CLabel,             -- RTS entry point for call
-           [(CgRep,CmmExpr)],   -- args to pass to the entry point
-           [(CgRep,CmmExpr)])   -- stuff to save on the stack
-
-   -- don't forget the zero case
-constructSlowCall []
-  = (mkRtsApFastLabel (fsLit "stg_ap_0"), [], [])
-
-constructSlowCall amodes
-  = (stg_ap_pat, these, rest)
-  where
-    stg_ap_pat = mkRtsApFastLabel arg_pat
-    (arg_pat, these, rest) = matchSlowPattern amodes
-
--- | 'slowArgs' takes a list of function arguments and prepares them for
--- pushing on the stack for "extra" arguments to a function which requires
--- fewer arguments than we currently have.
-slowArgs :: DynFlags -> [(CgRep,CmmExpr)] -> [(CgRep,CmmExpr)]
-slowArgs _ [] = []
-slowArgs dflags amodes
-  | gopt Opt_SccProfilingOn dflags = save_cccs ++ this_pat ++ slowArgs dflags rest
-  | otherwise                      =              this_pat ++ slowArgs dflags rest
-  where
-    (arg_pat, args, rest) = matchSlowPattern amodes
-    stg_ap_pat = mkCmmRetInfoLabel rtsPackageId arg_pat
-    this_pat   = (NonPtrArg, mkLblExpr stg_ap_pat) : args
-    save_cccs  = [(NonPtrArg, mkLblExpr save_cccs_lbl), (NonPtrArg, curCCS)]
-    save_cccs_lbl = mkCmmRetInfoLabel rtsPackageId (fsLit "stg_restore_cccs")
-
-matchSlowPattern :: [(CgRep,CmmExpr)]
-                 -> (FastString, [(CgRep,CmmExpr)], [(CgRep,CmmExpr)])
-matchSlowPattern amodes = (arg_pat, these, rest)
-  where (arg_pat, n)  = slowCallPattern (map fst amodes)
-        (these, rest) = splitAt n amodes
-
--- These cases were found to cover about 99% of all slow calls:
-slowCallPattern :: [CgRep] -> (FastString, Int)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _) = (fsLit "stg_ap_pppppp", 6)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: _)         = (fsLit "stg_ap_ppppp", 5)
-slowCallPattern (PtrArg: PtrArg: PtrArg: PtrArg: _)     = (fsLit "stg_ap_pppp", 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: VoidArg: _)    = (fsLit "stg_ap_pppv", 4)
-slowCallPattern (PtrArg: PtrArg: PtrArg: _)             = (fsLit "stg_ap_ppp", 3)
-slowCallPattern (PtrArg: PtrArg: VoidArg: _)            = (fsLit "stg_ap_ppv", 3)
-slowCallPattern (PtrArg: PtrArg: _)                     = (fsLit "stg_ap_pp", 2)
-slowCallPattern (PtrArg: VoidArg: _)                    = (fsLit "stg_ap_pv", 2)
-slowCallPattern (PtrArg: _)                             = (fsLit "stg_ap_p", 1)
-slowCallPattern (VoidArg: _)                            = (fsLit "stg_ap_v", 1)
-slowCallPattern (NonPtrArg: _)                          = (fsLit "stg_ap_n", 1)
-slowCallPattern (FloatArg: _)                           = (fsLit "stg_ap_f", 1)
-slowCallPattern (DoubleArg: _)                          = (fsLit "stg_ap_d", 1)
-slowCallPattern (LongArg: _)                            = (fsLit "stg_ap_l", 1)
-slowCallPattern _                                       = panic "CgStackery.slowCallPattern"
-
--------------------------------------------------------------------------
---
---              Return conventions
---
--------------------------------------------------------------------------
-
-dataReturnConvPrim :: CgRep -> CmmReg
-dataReturnConvPrim PtrArg    = CmmGlobal (VanillaReg 1 VGcPtr)
-dataReturnConvPrim NonPtrArg = CmmGlobal (VanillaReg 1 VNonGcPtr)
-dataReturnConvPrim LongArg   = CmmGlobal (LongReg 1)
-dataReturnConvPrim FloatArg  = CmmGlobal (FloatReg 1)
-dataReturnConvPrim DoubleArg = CmmGlobal (DoubleReg 1)
-dataReturnConvPrim VoidArg   = panic "dataReturnConvPrim: void"
-
-
--- getSequelAmode returns an amode which refers to an info table.  The info
--- table will always be of the RET_(BIG|SMALL) kind.  We're careful
--- not to handle real code pointers, just in case we're compiling for
--- an unregisterised/untailcallish architecture, where info pointers and
--- code pointers aren't the same.
--- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only
--- valid just before the final control transfer, because it assumes
--- that Sp is pointing to the top word of the return address.  This
--- seems unclean but there you go.
-
-getSequelAmode :: FCode CmmExpr
-getSequelAmode
-  = do  { EndOfBlockInfo virt_sp sequel <- getEndOfBlockInfo
-        ; case sequel of
-            OnStack -> do { dflags <- getDynFlags
-                          ; sp_rel <- getSpRelOffset virt_sp
-                          ; returnFC (CmmLoad sp_rel (bWord dflags)) }
-
-            CaseAlts lbl _ _  -> returnFC (CmmLit (CmmLabel lbl))
-        }
-
--------------------------------------------------------------------------
---
---              Register assignment
---
--------------------------------------------------------------------------
-
---  How to assign registers for
---
---      1) Calling a fast entry point.
---      2) Returning an unboxed tuple.
---      3) Invoking an out-of-line PrimOp.
---
--- Registers are assigned in order.
---
--- If we run out, we don't attempt to assign any further registers (even
--- though we might have run out of only one kind of register); we just
--- return immediately with the left-overs specified.
---
--- The alternative version @assignAllRegs@ uses the complete set of
--- registers, including those that aren't mapped to real machine
--- registers.  This is used for calling special RTS functions and PrimOps
--- which expect their arguments to always be in the same registers.
-
-type AssignRegs a = [(CgRep,a)]          -- Arg or result values to assign
-                 -> ([(a, GlobalReg)],   -- Register assignment in same order
-                                         -- for *initial segment of* input list
-                                         --   (but reversed; doesn't matter)
-                                         -- VoidRep args do not appear here
-                     [(CgRep,a)])        -- Leftover arg or result values
-
-assignCallRegs       :: DynFlags -> AssignRegs a
-assignPrimOpCallRegs :: DynFlags -> AssignRegs a
-assignReturnRegs     :: DynFlags -> AssignRegs a
-
-assignCallRegs dflags args
-  = assign_regs args (mkRegTbl dflags [node])
-        -- The entry convention for a function closure
-        -- never uses Node for argument passing; instead
-        -- Node points to the function closure itself
-
-assignPrimOpCallRegs dflags args
- = assign_regs args (mkRegTbl_allRegs dflags [])
-        -- For primops, *all* arguments must be passed in registers
-
-assignReturnRegs dflags args
- -- when we have a single non-void component to return, use the normal
- -- unpointed return convention.  This make various things simpler: it
- -- means we can assume a consistent convention for IO, which is useful
- -- when writing code that relies on knowing the IO return convention in
- -- the RTS (primops, especially exception-related primops).
- -- Also, the bytecode compiler assumes this when compiling
- -- case expressions and ccalls, so it only needs to know one set of
- -- return conventions.
- | [(rep,arg)] <- non_void_args, CmmGlobal r <- dataReturnConvPrim rep
-    = ([(arg, r)], [])
- | otherwise
-    = assign_regs args (mkRegTbl dflags [])
-        -- For returning unboxed tuples etc,
-        -- we use all regs
- where
-       non_void_args = filter ((/= VoidArg).fst) args
-
-assign_regs :: [(CgRep,a)]      -- Arg or result values to assign
-            -> AvailRegs        -- Regs still avail: Vanilla, Float, Double, Longs
-            -> ([(a, GlobalReg)], [(CgRep, a)])
-assign_regs args supply
-  = go args [] supply
-  where
-    go [] acc _ = (acc, [])     -- Return the results reversed (doesn't matter)
-    go ((VoidArg,_) : args) acc supply  -- Skip void arguments; they aren't passed, and
-        = go args acc supply            -- there's nothing to bind them to
-    go ((rep,arg) : args) acc supply
-        = case assign_reg rep supply of
-                Just (reg, supply') -> go args ((arg,reg):acc) supply'
-                Nothing             -> (acc, (rep,arg):args)    -- No more regs
-
-assign_reg :: CgRep -> AvailRegs -> Maybe (GlobalReg, AvailRegs)
-assign_reg FloatArg  (vs, f:fs, ds, ls) = Just (FloatReg f,   (vs, fs, ds, ls))
-assign_reg DoubleArg (vs, fs, d:ds, ls) = Just (DoubleReg d,  (vs, fs, ds, ls))
-assign_reg LongArg   (vs, fs, ds, l:ls) = Just (LongReg l,    (vs, fs, ds, ls))
-assign_reg PtrArg    (v:vs, fs, ds, ls) = Just (VanillaReg v VGcPtr, (vs, fs, ds, ls))
-assign_reg NonPtrArg (v:vs, fs, ds, ls) = Just (VanillaReg v VNonGcPtr, (vs, fs, ds, ls))
-    -- PtrArg and NonPtrArg both go in a vanilla register
-assign_reg _         _                  = Nothing
-
-
--------------------------------------------------------------------------
---
---              Register supplies
---
--------------------------------------------------------------------------
-
--- Vanilla registers can contain pointers, Ints, Chars.
--- Floats and doubles have separate register supplies.
---
--- We take these register supplies from the *real* registers, i.e. those
--- that are guaranteed to map to machine registers.
-
-useVanillaRegs :: DynFlags -> Int
-useVanillaRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Vanilla_REG dflags
-useFloatRegs :: DynFlags -> Int
-useFloatRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Float_REG dflags
-useDoubleRegs :: DynFlags -> Int
-useDoubleRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Double_REG dflags
-useLongRegs :: DynFlags -> Int
-useLongRegs dflags
- | platformUnregisterised (targetPlatform dflags) = 0
- | otherwise                                      = mAX_Real_Long_REG dflags
-
-vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
-vanillaRegNos dflags = regList $ useVanillaRegs dflags
-floatRegNos   dflags = regList $ useFloatRegs   dflags
-doubleRegNos  dflags = regList $ useDoubleRegs  dflags
-longRegNos    dflags = regList $ useLongRegs    dflags
-
-allVanillaRegNos, allFloatRegNos, allDoubleRegNos, allLongRegNos
-    :: DynFlags -> [Int]
-allVanillaRegNos dflags = regList $ mAX_Vanilla_REG dflags
-allFloatRegNos   dflags = regList $ mAX_Float_REG   dflags
-allDoubleRegNos  dflags = regList $ mAX_Double_REG  dflags
-allLongRegNos    dflags = regList $ mAX_Long_REG    dflags
-
-regList :: Int -> [Int]
-regList n = [1 .. n]
-
-type AvailRegs = ( [Int]   -- available vanilla regs.
-                 , [Int]   -- floats
-                 , [Int]   -- doubles
-                 , [Int]   -- longs (int64 and word64)
-                 )
-
-mkRegTbl :: DynFlags -> [GlobalReg] -> AvailRegs
-mkRegTbl dflags regs_in_use
-  = mkRegTbl' dflags regs_in_use
-              vanillaRegNos floatRegNos doubleRegNos longRegNos
-
-mkRegTbl_allRegs :: DynFlags -> [GlobalReg] -> AvailRegs
-mkRegTbl_allRegs dflags regs_in_use
-  = mkRegTbl' dflags regs_in_use
-              allVanillaRegNos allFloatRegNos allDoubleRegNos allLongRegNos
-
-mkRegTbl' :: DynFlags -> [GlobalReg]
-          -> (DynFlags -> [Int])
-          -> (DynFlags -> [Int])
-          -> (DynFlags -> [Int])
-          -> (DynFlags -> [Int])
-          -> ([Int], [Int], [Int], [Int])
-mkRegTbl' dflags regs_in_use vanillas floats doubles longs
-  = (ok_vanilla, ok_float, ok_double, ok_long)
-  where
-    ok_vanilla = mapCatMaybes (select (\i -> VanillaReg i VNonGcPtr))
-                              (vanillas dflags)
-                    -- ptrhood isn't looked at, hence we can use any old rep.
-    ok_float   = mapCatMaybes (select FloatReg)  (floats  dflags)
-    ok_double  = mapCatMaybes (select DoubleReg) (doubles dflags)
-    ok_long    = mapCatMaybes (select LongReg)   (longs   dflags)
-
-    select :: (Int -> GlobalReg) -> Int{-cand-} -> Maybe Int
-        -- one we've unboxed the Int, we make a GlobalReg
-        -- and see if it is already in use; if not, return its number.
-
-    select mk_reg_fun cand
-      = let
-            reg = mk_reg_fun cand
-        in
-        if reg `not_elem` regs_in_use
-        then Just cand
-        else Nothing
-      where
-        not_elem = isn'tIn "mkRegTbl"
-
-
diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
deleted file mode 100644 (file)
index 595a30e..0000000
+++ /dev/null
@@ -1,673 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-
-\begin{code}
-
-module CgCase (
-        cgCase,
-        saveVolatileVarsAndRegs,
-        restoreCurrentCostCentre
-    ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} CgExpr ( cgExpr )
-
-import CgMonad
-import CgBindery
-import CgCon
-import CgHeapery
-import CgCallConv
-import CgStackery
-import CgTailCall
-import CgPrimOp
-import CgForeignCall
-import CgUtils
-import CgProf
-import CgInfoTbls
-
-import ClosureInfo
-import OldCmmUtils
-import OldCmm
-
-import DynFlags
-import StgSyn
-import Id
-import ForeignCall
-import VarSet
-import CoreSyn
-import PrimOp
-import Type
-import TyCon
-import Util
-import Outputable
-import FastString
-
-import Control.Monad (when)
-\end{code}
-
-\begin{code}
-data GCFlag
-  = GCMayHappen -- The scrutinee may involve GC, so everything must be
-                -- tidy before the code for the scrutinee.
-
-  | NoGC        -- The scrutinee is a primitive value, or a call to a
-                -- primitive op which does no GC.  Hence the case can
-                -- be done inline, without tidying up first.
-\end{code}
-
-It is quite interesting to decide whether to put a heap-check
-at the start of each alternative.  Of course we certainly have
-to do so if the case forces an evaluation, or if there is a primitive
-op which can trigger GC.
-
-A more interesting situation is this:
-
- \begin{verbatim}
-        !A!;
-        ...A...
-        case x# of
-          0#      -> !B!; ...B...
-          default -> !C!; ...C...
- \end{verbatim}
-
-where \tr{!x!} indicates a possible heap-check point. The heap checks
-in the alternatives {\em can} be omitted, in which case the topmost
-heapcheck will take their worst case into account.
-
-In favour of omitting \tr{!B!}, \tr{!C!}:
-
- - {\em May} save a heap overflow test,
-        if ...A... allocates anything.  The other advantage
-        of this is that we can use relative addressing
-        from a single Hp to get at all the closures so allocated.
-
- - No need to save volatile vars etc across the case
-
-Against:
-
-  - May do more allocation than reqd.  This sometimes bites us
-        badly.  For example, nfib (ha!)  allocates about 30\% more space if the
-        worst-casing is done, because many many calls to nfib are leaf calls
-        which don't need to allocate anything.
-
-        This never hurts us if there is only one alternative.
-
-\begin{code}
-cgCase  :: StgExpr
-        -> StgLiveVars
-        -> StgLiveVars
-        -> Id
-        -> AltType
-        -> [StgAlt]
-        -> Code
-\end{code}
-
-Special case #1: case of literal.
-
-\begin{code}
-cgCase (StgLit lit) _live_in_whole_case _live_in_alts bndr
-       alt_type@(PrimAlt _) alts
-  = do  { tmp_reg <- bindNewToTemp bndr
-        ; cm_lit <- cgLit lit
-        ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit))
-        ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
-\end{code}
-
-Special case #2: scrutinising a primitive-typed variable.       No
-evaluation required.  We don't save volatile variables, nor do we do a
-heap-check in the alternatives.  Instead, the heap usage of the
-alternatives is worst-cased and passed upstream.  This can result in
-allocating more heap than strictly necessary, but it will sometimes
-eliminate a heap check altogether.
-
-\begin{code}
-cgCase (StgApp _v []) _live_in_whole_case _live_in_alts bndr
-       (PrimAlt _) [(DEFAULT,bndrs,_,rhs)]
-  | isVoidArg (idCgRep bndr)
-  = ASSERT( null bndrs )
-    WARN( True, ptext (sLit "Case of void constant; missing optimisation somewhere") <+> ppr bndr)
-    cgExpr rhs
-
-cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
-       alt_type@(PrimAlt _) alts
-  -- Note [ticket #3132]: we might be looking at a case of a lifted Id
-  -- that was cast to an unlifted type.  The Id will always be bottom,
-  -- but we don't want the code generator to fall over here.  If we
-  -- just emit an assignment here, the assignment will be
-  -- type-incorrect Cmm.  Hence we check that the types match, and if
-  -- they don't we'll fall through and emit the usual enter/return
-  -- code.  Test case: codeGen/should_compile/3132.hs
-  | isUnLiftedType (idType v)
-
-  -- However, we also want to allow an assignment to be generated
-  -- in the case when the types are compatible, because this allows
-  -- some slightly-dodgy but occasionally-useful casts to be used,
-  -- such as in RtClosureInspect where we cast an HValue to a MutVar#
-  -- so we can print out the contents of the MutVar#.  If we generate
-  -- code that enters the HValue, then we'll get a runtime panic, because
-  -- the HValue really is a MutVar#.  The types are compatible though,
-  -- so we can just generate an assignment.
-  || reps_compatible
-  =  do { when (not reps_compatible) $
-            panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
-
-          -- Careful! we can't just bind the default binder to the same thing
-          -- as the scrutinee, since it might be a stack location, and having
-          -- two bindings pointing at the same stack locn doesn't work (it
-          -- confuses nukeDeadBindings).  Hence, use a new temp.
-        ; v_info <- getCgIdInfo v
-        ; amode <- idInfoToAmode v_info
-        ; tmp_reg <- bindNewToTemp bndr
-        ; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
-
-        ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
-  where
-    reps_compatible = idCgRep v == idCgRep bndr
-\end{code}
-
-Special case #2.5; seq#
-
-  case seq# a s of v
-    (# s', a' #) -> e
-
-  ==>
-
-  case a of v
-    (# s', a' #) -> e
-
-  (taking advantage of the fact that the return convention for (# State#, a #)
-  is the same as the return convention for just 'a')
-
-\begin{code}
-cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _)
-       live_in_whole_case live_in_alts bndr alt_type alts
-  = cgCase (StgApp a []) live_in_whole_case live_in_alts bndr alt_type alts
-\end{code}
-
-Special case #3: inline PrimOps and foreign calls.
-
-\begin{code}
-cgCase (StgOpApp (StgPrimOp primop) args _)
-       _live_in_whole_case live_in_alts bndr alt_type alts
-  | not (primOpOutOfLine primop)
-  = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
-\end{code}
-
-TODO: Case-of-case of primop can probably be done inline too (but
-maybe better to translate it out beforehand).  See
-ghc/lib/misc/PackedString.lhs for examples where this crops up (with
-4.02).
-
-Special case #4: inline foreign calls: an unsafe foreign call can be done
-right here, just like an inline primop.
-
-\begin{code}
-cgCase (StgOpApp (StgFCallOp fcall _) args _)
-       _live_in_whole_case live_in_alts _bndr _alt_type alts
-  | unsafe_foreign_call
-  = ASSERT( isSingleton alts )
-    do  --  *must* be an unboxed tuple alt.
-        -- exactly like the cgInlinePrimOp case for unboxed tuple alts..
-        { res_tmps <- mapFCs bindNewToTemp non_void_res_ids
-        ; let res_hints = map (typeForeignHint.idType) non_void_res_ids
-        ; cgForeignCall (zipWith CmmHinted res_tmps res_hints) fcall args live_in_alts
-        ; cgExpr rhs }
-  where
-   (_, res_ids, _, rhs) = head alts
-   non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
-
-   unsafe_foreign_call
-         = case fcall of
-                CCall (CCallSpec _ _ s) -> not (playSafe s)
-\end{code}
-
-Special case: scrutinising a non-primitive variable.
-This can be done a little better than the general case, because
-we can reuse/trim the stack slot holding the variable (if it is in one).
-
-\begin{code}
-cgCase (StgApp fun args)
-        _live_in_whole_case live_in_alts bndr alt_type alts
-  = do  { fun_info <- getCgIdInfo fun
-        ; arg_amodes <- getArgAmodes args
-
-        -- Nuking dead bindings *before* calculating the saves is the
-        -- value-add here.  We might end up freeing up some slots currently
-        -- occupied by variables only required for the call.
-        -- NOTE: we need to look up the variables used in the call before
-        -- doing this, because some of them may not be in the environment
-        -- afterward.
-        ; nukeDeadBindings live_in_alts
-        ; (save_assts, alts_eob_info, maybe_cc_slot)
-            <- saveVolatileVarsAndRegs live_in_alts
-
-        ; scrut_eob_info
-            <- forkEval alts_eob_info
-                        (allocStackTop retAddrSizeW >> nopC)
-                        (do { deAllocStackTop retAddrSizeW
-                            ; cgEvalAlts maybe_cc_slot bndr alt_type alts })
-
-        ; setEndOfBlockInfo scrut_eob_info
-                            (performTailCall fun_info arg_amodes save_assts) }
-\end{code}
-
-Note about return addresses: we *always* push a return address, even
-if because of an optimisation we end up jumping direct to the return
-code (not through the address itself).  The alternatives always assume
-that the return address is on the stack.  The return address is
-required in case the alternative performs a heap check, since it
-encodes the liveness of the slots in the activation record.
-
-On entry to the case alternative, we can re-use the slot containing
-the return address immediately after the heap check.  That's what the
-deAllocStackTop call is doing above.
-
-Finally, here is the general case.
-
-\begin{code}
-cgCase expr live_in_whole_case live_in_alts bndr alt_type alts
-  = do  {       -- Figure out what volatile variables to save
-          nukeDeadBindings live_in_whole_case
-
-        ; (save_assts, alts_eob_info, maybe_cc_slot)
-                <- saveVolatileVarsAndRegs live_in_alts
-
-             -- Save those variables right now!
-        ; emitStmts save_assts
-
-            -- generate code for the alts
-        ; scrut_eob_info
-               <- forkEval alts_eob_info
-                           (do  { nukeDeadBindings live_in_alts
-                                ; allocStackTop retAddrSizeW   -- space for retn address
-                                ; nopC })
-                           (do  { deAllocStackTop retAddrSizeW
-                                ; cgEvalAlts maybe_cc_slot bndr alt_type alts })
-
-        ; setEndOfBlockInfo scrut_eob_info (cgExpr expr)
-    }
-\end{code}
-
-There's a lot of machinery going on behind the scenes to manage the
-stack pointer here.  forkEval takes the virtual Sp and free list from
-the first argument, and turns that into the *real* Sp for the second
-argument.  It also uses this virtual Sp as the args-Sp in the EOB info
-returned, so that the scrutinee will trim the real Sp back to the
-right place before doing whatever it does.
-  --SDM (who just spent an hour figuring this out, and didn't want to
-         forget it).
-
-Why don't we push the return address just before evaluating the
-scrutinee?  Because the slot reserved for the return address might
-contain something useful, so we wait until performing a tail call or
-return before pushing the return address (see
-CgTailCall.pushReturnAddress).
-
-This also means that the environment doesn't need to know about the
-free stack slot for the return address (for generating bitmaps),
-because we don't reserve it until just before the eval.
-
-TODO!!  Problem: however, we have to save the current cost centre
-stack somewhere, because at the eval point the current CCS might be
-different.  So we pick a free stack slot and save CCCS in it.  One
-consequence of this is that activation records on the stack don't
-follow the layout of closures when we're profiling.  The CCS could be
-anywhere within the record).
-
-%************************************************************************
-%*                                                                      *
-                Inline primops
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-cgInlinePrimOp :: PrimOp -> [StgArg] -> Id -> AltType -> StgLiveVars
-               -> [(AltCon, [Id], [Bool], StgExpr)]
-               -> Code
-cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts
-  | isVoidArg (idCgRep bndr)
-  = ASSERT( con == DEFAULT && isSingleton alts && null bs )
-    do  {       -- VOID RESULT; just sequencing,
-                -- so get in there and do it
-                -- The bndr should not occur, so no need to bind it
-          cgPrimOp [] primop args live_in_alts
-        ; cgExpr rhs }
-  where
-    (con,bs,_,rhs) = head alts
-
-cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
-  = do  {       -- PRIMITIVE ALTS, with non-void result
-          tmp_reg <- bindNewToTemp bndr
-        ; cgPrimOp [tmp_reg] primop args live_in_alts
-        ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts }
-
-cgInlinePrimOp primop args _ (UbxTupAlt _) live_in_alts alts
-  = ASSERT( isSingleton alts )
-    do  {       -- UNBOXED TUPLE ALTS
-                -- No heap check, no yield, just get in there and do it.
-                -- NB: the case binder isn't bound to anything;
-                --     it has a unboxed tuple type
-
-          res_tmps <- mapFCs bindNewToTemp non_void_res_ids
-        ; cgPrimOp res_tmps primop args live_in_alts
-        ; cgExpr rhs }
-  where
-   (_, res_ids, _, rhs) = head alts
-   non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
-
-cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
-  = do  {       -- ENUMERATION TYPE RETURN
-                -- Typical: case a ># b of { True -> ..; False -> .. }
-                -- The primop itself returns an index into the table of
-                -- closures for the enumeration type.
-           tag_amode <- ASSERT( isEnumerationTyCon tycon )
-                        do_enum_primop primop
-
-                -- Bind the default binder if necessary
-                -- (avoiding it avoids the assignment)
-                -- The deadness info is set by StgVarInfo
-        ; whenC (not (isDeadBinder bndr))
-                (do { dflags <- getDynFlags
-                    ; tmp_reg <- bindNewToTemp bndr
-                    ; stmtC (CmmAssign
-                             (CmmLocal tmp_reg)
-                             (tagToClosure dflags tycon tag_amode)) })
-
-                -- Compile the alts
-        ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
-                                            (AlgAlt tycon) alts
-
-                -- Do the switch
-        ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1)
-        }
-  where
-
-    do_enum_primop :: PrimOp -> FCode CmmExpr   -- Returns amode for result
-    do_enum_primop TagToEnumOp  -- No code!
-       | [arg] <- args = do
-         (_,e) <- getArgAmode arg
-         return e
-    do_enum_primop primop
-      = do dflags <- getDynFlags
-           tmp <- newTemp (bWord dflags)
-           cgPrimOp [tmp] primop args live_in_alts
-           returnFC (CmmReg (CmmLocal tmp))
-
-cgInlinePrimOp _ _ bndr _ _ _
-  = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgCase-alts]{Alternatives}
-%*                                                                      *
-%************************************************************************
-
-@cgEvalAlts@ returns an addressing mode for a continuation for the
-alternatives of a @case@, used in a context when there
-is some evaluation to be done.
-
-\begin{code}
-cgEvalAlts :: Maybe VirtualSpOffset     -- Offset of cost-centre to be restored, if any
-           -> Id
-           -> AltType
-           -> [StgAlt]
-           -> FCode Sequel      -- Any addr modes inside are guaranteed
-                                -- to be a label so that we can duplicate it
-                                -- without risk of duplicating code
-
-cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts
-  = do  { let   rep = tyConCgRep tycon
-                reg = dataReturnConvPrim rep    -- Bottom for voidRep
-
-        ; abs_c <- forkProc $ do
-                {       -- Bind the case binder, except if it's void
-                        -- (reg is bottom in that case)
-                  whenC (nonVoidArg rep) $
-                  bindNewToReg bndr reg (mkLFArgument bndr)
-                ; restoreCurrentCostCentre cc_slot True
-                ; cgPrimAlts GCMayHappen alt_type reg alts }
-
-        ; lbl <- emitReturnTarget (idName bndr) abs_c
-        ; returnFC (CaseAlts lbl Nothing bndr) }
-
-cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)]
-  =     -- Unboxed tuple case
-        -- By now, the simplifier should have have turned it
-        -- into         case e of (# a,b #) -> e
-        -- There shouldn't be a
-        --              case e of DEFAULT -> e
-    ASSERT2( case con of { DataAlt _ -> True; _ -> False },
-             text "cgEvalAlts: dodgy case of unboxed tuple type" )
-    do  {       -- forkAbsC for the RHS, so that the envt is
-                -- not changed for the emitReturn call
-          abs_c <- forkProc $ do
-                { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args
-                        -- Restore the CC *after* binding the tuple components,
-                        -- so that we get the stack offset of the saved CC right.
-                ; restoreCurrentCostCentre cc_slot True
-                        -- Generate a heap check if necessary
-                        -- and finally the code for the alternative
-                ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
-                                     (cgExpr rhs) }
-        ; lbl <- emitReturnTarget (idName bndr) abs_c
-        ; returnFC (CaseAlts lbl Nothing bndr) }
-
-cgEvalAlts cc_slot bndr alt_type alts
-  =     -- Algebraic and polymorphic case
-    do  {       -- Bind the default binder
-          bindNewToReg bndr nodeReg (mkLFArgument bndr)
-
-        -- Generate sequel info for use downstream
-        -- At the moment, we only do it if the type is vector-returnable.
-        -- Reason: if not, then it costs extra to label the
-        -- alternatives, because we'd get return code like:
-        --
-        --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
-        --
-        -- which is worse than having the alt code in the switch statement
-
-        ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
-
-        ; (lbl, branches) <- emitAlgReturnTarget (idName bndr)
-                                alts mb_deflt fam_sz
-
-        ; returnFC (CaseAlts lbl branches bndr) }
-  where
-    fam_sz = case alt_type of
-                AlgAlt tc -> tyConFamilySize tc
-                PolyAlt   -> 0
-                PrimAlt _ -> panic "cgEvalAlts: PrimAlt"
-                UbxTupAlt _ -> panic "cgEvalAlts: UbxTupAlt"
-\end{code}
-
-
-HWL comment on {\em GrAnSim\/}  (adding GRAN_YIELDs for context switch): If
-we  do  an inlining of the  case  no separate  functions  for returning are
-created, so we don't have to generate a GRAN_YIELD in that case.  This info
-must be  propagated  to cgAlgAltRhs (where the  GRAN_YIELD  macro might  be
-emitted). Hence, the new Bool arg to cgAlgAltRhs.
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgCase-alg-alts]{Algebraic alternatives}
-%*                                                                      *
-%************************************************************************
-
-In @cgAlgAlts@, none of the binders in the alternatives are
-assumed to be yet bound.
-
-HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
-last   arg of  cgAlgAlts  indicates  if we  want  a context   switch at the
-beginning of  each alternative. Normally we  want that. The  only exception
-are inlined alternatives.
-
-\begin{code}
-cgAlgAlts :: GCFlag
-       -> Maybe VirtualSpOffset
-       -> AltType                               --  ** AlgAlt or PolyAlt only **
-       -> [StgAlt]                              -- The alternatives
-       -> FCode ( [(ConTagZ, CgStmts)], -- The branches
-                  Maybe CgStmts )       -- The default case
-
-cgAlgAlts gc_flag cc_slot alt_type alts
-  = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts]
-       let
-            mb_deflt = case alts of -- DEFAULT is always first, if present
-                         ((DEFAULT,blks) : _) -> Just blks
-                         _                    -> Nothing
-
-            branches = [(dataConTagZ con, blks)
-                       | (DataAlt con, blks) <- alts]
-       return (branches, mb_deflt)
-
-
-cgAlgAlt :: GCFlag
-         -> Maybe VirtualSpOffset       -- Turgid state
-         -> AltType                     --  ** AlgAlt or PolyAlt only **
-         -> StgAlt
-         -> FCode (AltCon, CgStmts)
-
-cgAlgAlt gc_flag cc_slot alt_type (con, args, _use_mask, rhs)
-  = do  { abs_c <- getCgStmts $ do
-                { bind_con_args con args
-                ; restoreCurrentCostCentre cc_slot True
-                ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) }
-        ; return (con, abs_c) }
-  where
-    bind_con_args DEFAULT      _    = nopC
-    bind_con_args (DataAlt dc) args = bindConArgs dc args
-    bind_con_args (LitAlt _)   _    = panic "cgAlgAlt: LitAlt"
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgCase-prim-alts]{Primitive alternatives}
-%*                                                                      *
-%************************************************************************
-
-@cgPrimAlts@ generates suitable a @CSwitch@
-for dealing with the alternatives of a primitive @case@, given an
-addressing mode for the thing to scrutinise.  It also keeps track of
-the maximum stack depth encountered down any branch.
-
-As usual, no binders in the alternatives are yet bound.
-
-\begin{code}
-cgPrimAlts :: GCFlag
-           -> AltType   -- Always PrimAlt, but passed to maybeAltHeapCheck
-           -> CmmReg    -- Scrutinee
-           -> [StgAlt]  -- Alternatives
-           -> Code
--- NB: cgPrimAlts emits code that does the case analysis.
--- It's often used in inline situations, rather than to genearte
--- a labelled return point.  That's why its interface is a little
--- different to cgAlgAlts
---
--- INVARIANT: the default binder is already bound
-cgPrimAlts gc_flag alt_type scrutinee alts
-  = do  { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts)
-        ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs   -- There is always a default
-              alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
-        ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC }
-
-cgPrimAlt :: GCFlag
-          -> AltType
-          -> StgAlt                             -- The alternative
-          -> FCode (AltCon, CgStmts)    -- Its compiled form
-
-cgPrimAlt gc_flag alt_type (con, [], [], rhs)
-  = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; _ -> False } )
-    do  { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs))
-        ; returnFC (con, abs_c) }
-cgPrimAlt _ _ _ = panic "cgPrimAlt: non-empty lists"
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgCase-tidy]{Code for tidying up prior to an eval}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-maybeAltHeapCheck
-        :: GCFlag
-        -> AltType      -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
-        -> Code         -- Continuation
-        -> Code
-maybeAltHeapCheck NoGC        _        code = code
-maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code
-
-saveVolatileVarsAndRegs
-    :: StgLiveVars                    -- Vars which should be made safe
-    -> FCode (CmmStmts,               -- Assignments to do the saves
-              EndOfBlockInfo,         -- sequel for the alts
-              Maybe VirtualSpOffset)  -- Slot for current cost centre
-
-saveVolatileVarsAndRegs vars
-  = do  { var_saves <- saveVolatileVars vars
-        ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre
-        ; eob_info <- getEndOfBlockInfo
-        ; returnFC (var_saves `plusStmts` cc_save,
-                    eob_info,
-                    maybe_cc_slot) }
-
-
-saveVolatileVars :: StgLiveVars         -- Vars which should be made safe
-                 -> FCode CmmStmts      -- Assignments to to the saves
-
-saveVolatileVars vars
-  = do  { stmts_s <- mapFCs save_it (varSetElems vars)
-        ; return (foldr plusStmts noStmts stmts_s) }
-  where
-    save_it var
-      = do { v <- getCAddrModeIfVolatile var
-           ; case v of
-                Nothing         -> return noStmts          -- Non-volatile
-                Just vol_amode  -> save_var var vol_amode  -- Aha! It's volatile
-        }
-
-    save_var var vol_amode
-      = do { slot <- allocPrimStack (idCgRep var)
-           ; rebindToStack var slot
-           ; sp_rel <- getSpRelOffset slot
-           ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) }
-\end{code}
-
----------------------------------------------------------------------------
-
-When we save the current cost centre (which is done for lexical
-scoping), we allocate a free stack location, and return (a)~the
-virtual offset of the location, to pass on to the alternatives, and
-(b)~the assignment to do the save (just as for @saveVolatileVars@).
-
-\begin{code}
-saveCurrentCostCentre ::
-        FCode (Maybe VirtualSpOffset,   -- Where we decide to store it
-               CmmStmts)                -- Assignment to save it
-
-saveCurrentCostCentre
-  = do dflags <- getDynFlags
-       if not (gopt Opt_SccProfilingOn dflags)
-           then returnFC (Nothing, noStmts)
-           else do slot <- allocPrimStack PtrArg
-                   sp_rel <- getSpRelOffset slot
-                   returnFC (Just slot,
-                             oneStmt (CmmStore sp_rel curCCS))
-
--- Sometimes we don't free the slot containing the cost centre after restoring it
--- (see CgLetNoEscape.cgLetNoEscapeBody).
-restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
-restoreCurrentCostCentre Nothing     _freeit = nopC
-restoreCurrentCostCentre (Just slot) freeit
- = do   { dflags <- getDynFlags
-        ; sp_rel <- getSpRelOffset slot
-        ; whenC freeit (freeStackSlots [slot])
-        ; stmtC (storeCurCCS (CmmLoad sp_rel (bWord dflags))) }
-\end{code}
-
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
deleted file mode 100644 (file)
index b5ce231..0000000
+++ /dev/null
@@ -1,641 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgClosure]{Code generation for closures}
-
-This module provides the support code for @StgToAbstractC@ to deal
-with {\em closures} on the RHSs of let(rec)s.  See also
-@CgCon@, which deals with constructors.
-
-\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgClosure ( cgTopRhsClosure, 
-                  cgStdRhsClosure, 
-                  cgRhsClosure,
-                  emitBlackHoleCode,
-                  ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} CgExpr ( cgExpr )
-
-import CgMonad
-import CgBindery
-import CgHeapery
-import CgStackery
-import CgProf
-import CgTicky
-import CgParallel
-import CgInfoTbls
-import CgCallConv
-import CgUtils
-import ClosureInfo
-import SMRep
-import OldCmm
-import OldCmmUtils
-import CLabel
-import StgSyn
-import CostCentre      
-import Id
-import Name
-import Module
-import ListSetOps
-import Util
-import BasicTypes
-import DynFlags
-import Outputable
-import FastString
-
-import Data.List
-\end{code}
-
-%********************************************************
-%*                                                     *
-\subsection[closures-no-free-vars]{Top-level closures}
-%*                                                     *
-%********************************************************
-
-For closures bound at top level, allocate in static space.
-They should have no free variables.
-
-\begin{code}
-cgTopRhsClosure :: Id
-               -> CostCentreStack      -- Optional cost centre annotation
-               -> StgBinderInfo
-               -> UpdateFlag
-               -> [Id]         -- Args
-               -> StgExpr
-               -> FCode (Id, CgIdInfo)
-
-cgTopRhsClosure id ccs binder_info upd_flag args body = do
-  {    -- LAY OUT THE OBJECT
-    let name = idName id
-  ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
-  ; srt_info <- getSRTInfo
-  ; mod_name <- getModuleName
-  ; dflags   <- getDynFlags
-  ; let descr         = closureDescription dflags mod_name name
-       closure_info  = mkClosureInfo dflags True id lf_info 0 0 srt_info descr
-       closure_label = mkLocalClosureLabel name $ idCafInfo id
-       cg_id_info    = stableIdInfo dflags id (mkLblExpr closure_label) lf_info
-       closure_rep   = mkStaticClosureFields dflags closure_info ccs True []
-
-        -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
-  ; emitDataLits closure_label closure_rep
-  ; forkClosureBody (closureCodeBody binder_info closure_info
-                                    ccs args body)
-
-  ; returnFC (id, cg_id_info) }
-\end{code}
-
-%********************************************************
-%*                                                     *
-\subsection[non-top-level-closures]{Non top-level closures}
-%*                                                     *
-%********************************************************
-
-For closures with free vars, allocate in heap.
-
-\begin{code}
-cgStdRhsClosure
-       :: Id
-       -> CostCentreStack      -- Optional cost centre annotation
-       -> StgBinderInfo
-       -> [Id]                 -- Free vars
-       -> [Id]                 -- Args
-       -> StgExpr
-       -> LambdaFormInfo
-       -> [StgArg]             -- payload
-       -> FCode (Id, CgIdInfo)
-
-cgStdRhsClosure bndr _cc _bndr_info _fvs _args _body lf_info payload
-  = do -- AHA!  A STANDARD-FORM THUNK
-  {    -- LAY OUT THE OBJECT
-    amodes <- getArgAmodes payload
-  ; mod_name <- getModuleName
-  ; dflags <- getDynFlags
-  ; let (tot_wds, ptr_wds, amodes_w_offsets) 
-           = mkVirtHeapOffsets dflags (isLFThunk lf_info) amodes
-
-       descr        = closureDescription dflags mod_name (idName bndr)
-       closure_info = mkClosureInfo dflags False       -- Not static
-                                    bndr lf_info tot_wds ptr_wds 
-                                    NoC_SRT    -- No SRT for a std-form closure
-                                    descr
-               
---  ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
-
-       -- BUILD THE OBJECT
-  ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets
-
-       -- RETURN
-  ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) }
-\end{code}
-
-Here's the general case.
-
-\begin{code}
-cgRhsClosure   :: Id
-               -> CostCentreStack      -- Optional cost centre annotation
-               -> StgBinderInfo
-               -> [Id]                 -- Free vars
-               -> UpdateFlag
-               -> [Id]                 -- Args
-               -> StgExpr
-               -> FCode (Id, CgIdInfo)
-
-cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
-  {    -- LAY OUT THE OBJECT
-       -- If the binder is itself a free variable, then don't store
-       -- it in the closure.  Instead, just bind it to Node on entry.
-       -- NB we can be sure that Node will point to it, because we
-       -- havn't told mkClosureLFInfo about this; so if the binder
-       -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-       -- stored in the closure itself, so it will make sure that
-       -- Node points to it...
-    let
-       name         = idName bndr
-       bndr_is_a_fv = bndr `elem` fvs
-       reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
-                   | otherwise    = fvs
-
-  ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
-  ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
-  ; srt_info <- getSRTInfo
-  ; mod_name <- getModuleName
-  ; dflags <- getDynFlags
-  ; let        bind_details :: [(CgIdInfo, VirtualHpOffset)]
-       (tot_wds, ptr_wds, bind_details) 
-          = mkVirtHeapOffsets dflags (isLFThunk lf_info) (map add_rep fv_infos)
-
-       add_rep info = (cgIdInfoArgRep info, info)
-
-       descr        = closureDescription dflags mod_name name
-       closure_info = mkClosureInfo dflags False       -- Not static
-                                    bndr lf_info tot_wds ptr_wds
-                                    srt_info descr
-
-       -- BUILD ITS INFO TABLE AND CODE
-  ; forkClosureBody (do
-       {       -- Bind the fvs
-         let 
-              -- A function closure pointer may be tagged, so we
-              -- must take it into account when accessing the free variables.
-              mbtag       = tagForArity dflags (length args)
-              bind_fv (info, offset)
-                | Just tag <- mbtag
-                = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
-                | otherwise
-               = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
-       ; mapCs bind_fv bind_details
-
-               -- Bind the binder itself, if it is a free var
-       ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
-       
-               -- Compile the body
-       ; closureCodeBody bndr_info closure_info cc args body })
-
-       -- BUILD THE OBJECT
-  ; let
-       to_amode (info, offset) = do { amode <- idInfoToAmode info
-                                    ; return (amode, offset) }
---  ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
-  ; amodes_w_offsets <- mapFCs to_amode bind_details
-  ; heap_offset <- allocDynClosure closure_info curCCS curCCS amodes_w_offsets
-
-       -- RETURN
-  ; returnFC (bndr, heapIdInfo dflags bndr heap_offset lf_info) }
-
-
-mkClosureLFInfo :: Id          -- The binder
-               -> TopLevelFlag -- True of top level
-               -> [Id]         -- Free vars
-               -> UpdateFlag   -- Update flag
-               -> [Id]         -- Args
-               -> FCode LambdaFormInfo
-mkClosureLFInfo bndr top fvs upd_flag args
-  | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
-  | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
-                  ; return (mkLFReEntrant top fvs args arg_descr) }
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection[code-for-closures]{The code for closures}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-closureCodeBody :: StgBinderInfo
-               -> ClosureInfo     -- Lots of information about this closure
-               -> CostCentreStack -- Optional cost centre attached to closure
-               -> [Id]
-               -> StgExpr
-               -> Code
-\end{code}
-
-There are two main cases for the code for closures.  If there are {\em
-no arguments}, then the closure is a thunk, and not in normal form.
-So it should set up an update frame (if it is shared).
-NB: Thunks cannot have a primitive type!
-
-\begin{code}
-closureCodeBody _binder_info cl_info _cc [{- No args i.e. thunk -}] body = do
-  { body_absC <- getCgStmts $ do
-       { tickyEnterThunk cl_info
-       ; ldvEnterClosure cl_info  -- NB: Node always points when profiling
-       ; thunkWrapper cl_info $ do
-               -- We only enter cc after setting up update so
-               -- that cc of enclosing scope will be recorded
-                -- in the update frame
-            { enterCostCentreThunk (CmmReg nodeReg)
-           ; cgExpr body }
-       }
-    
-  ; emitClosureCodeAndInfoTable cl_info [] body_absC }
-\end{code}
-
-If there is /at least one argument/, then this closure is in
-normal form, so there is no need to set up an update frame.
-
-The Macros for GrAnSim are produced at the beginning of the
-argSatisfactionCheck (by calling fetchAndReschedule).  There info if
-Node points to closure is available. -- HWL
-
-\begin{code}
-closureCodeBody _binder_info cl_info cc args body 
-  = ASSERT( length args > 0 )
-  do {
-    dflags <- getDynFlags
-        -- Get the current virtual Sp (it might not be zero, 
-       -- eg. if we're compiling a let-no-escape).
-  ; vSp <- getVirtSp
-  ; let (reg_args, other_args) = assignCallRegs dflags (addIdReps args)
-       (sp_top, stk_args)     = mkVirtStkOffsets dflags vSp other_args
-
-       -- Allocate the global ticky counter
-  ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
-  ; emitTickyCounter cl_info args sp_top
-
-       -- ...and establish the ticky-counter 
-       -- label for this block
-  ; setTickyCtrLabel ticky_ctr_lbl $ do
-
-       -- Emit the slow-entry code
-  { dflags <- getDynFlags
-  ; reg_save_code <- mkSlowEntryCode dflags cl_info reg_args
-
-       -- Emit the main entry code
-  ; blks <- forkProc $
-           mkFunEntryCode cl_info cc reg_args stk_args
-                          sp_top reg_save_code body
-  ; emitClosureCodeAndInfoTable cl_info [] blks
-  }}
-
-
-
-mkFunEntryCode :: ClosureInfo
-              -> CostCentreStack
-              -> [(Id,GlobalReg)]        -- Args in regs
-              -> [(Id,VirtualSpOffset)]  -- Args on stack
-              -> VirtualSpOffset         -- Last allocated word on stack
-              -> CmmStmts                -- Register-save code in case of GC
-              -> StgExpr
-              -> Code
--- The main entry code for the closure
-mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
-  {    -- Bind args to regs/stack as appropriate,
-       -- and record expected position of sps
-  ; bindArgsToRegs  reg_args
-  ; bindArgsToStack stk_args
-  ; setRealAndVirtualSp sp_top
-
-        -- Do the business
-  ; funWrapper cl_info reg_args reg_save_code $ do
-        { dflags <- getDynFlags
-        ; tickyEnterFun cl_info
-        ; enterCostCentreFun cc
-              (CmmMachOp (mo_wordSub dflags) [ CmmReg nodeReg
-                                             , mkIntExpr dflags (funTag dflags cl_info) ])
-              (node : map snd reg_args) -- live regs
-
-        ; cgExpr body }
-  }
-\end{code}
-
-The "slow entry" code for a function.  This entry point takes its
-arguments on the stack.  It loads the arguments into registers
-according to the calling convention, and jumps to the function's
-normal entry point.  The function's closure is assumed to be in
-R1/node.
-
-The slow entry point is used in two places:
-
- (a) unknown calls: eg. stg_PAP_entry 
- (b) returning from a heap-check failure
-
-\begin{code}
-mkSlowEntryCode :: DynFlags -> ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
--- If this function doesn't have a specialised ArgDescr, we need
--- to generate the function's arg bitmap, slow-entry code, and
--- register-save code for the heap-check failure
--- Here, we emit the slow-entry code, and 
--- return the register-save assignments
-mkSlowEntryCode dflags cl_info reg_args
-  | Just (_, ArgGen _) <- closureFunInfo cl_info
-  = do         { emitSimpleProc slow_lbl (emitStmts load_stmts)
-       ; return save_stmts }
-  | otherwise = return noStmts
-  where
-     name = closureName cl_info
-     has_caf_refs = clHasCafRefs cl_info
-     slow_lbl = mkSlowEntryLabel name has_caf_refs
-
-     load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
-     save_stmts = oneStmt stk_adj_push `plusStmts`  mkStmts save_assts
-
-     reps_w_regs :: [(CgRep,GlobalReg)]
-     reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
-     (final_stk_offset, stk_offsets)
-       = mapAccumL (\off (rep,_) -> (off + cgRepSizeW dflags rep, off))
-                   0 reps_w_regs
-
-
-     load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
-     mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) 
-                                         (CmmLoad (cmmRegOffW dflags spReg offset)
-                                                  (argMachRep dflags rep))
-
-     save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
-     mk_save (rep,reg) offset = ASSERT( argMachRep dflags rep `cmmEqType` globalRegType dflags reg )
-                               CmmStore (cmmRegOffW dflags spReg offset)
-                                        (CmmReg (CmmGlobal reg))
-
-     stk_adj_pop   = CmmAssign spReg (cmmRegOffW dflags spReg final_stk_offset)
-     stk_adj_push  = CmmAssign spReg (cmmRegOffW dflags spReg (- final_stk_offset))
-     live_regs     = Just $ map snd reps_w_regs
-     jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI dflags cl_info)) live_regs
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsubsection[closure-code-wrappers]{Wrappers around closure code}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-thunkWrapper:: ClosureInfo -> Code -> Code
-thunkWrapper closure_info thunk_code = do
-  { dflags <- getDynFlags
-  ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
-
-    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-    -- (we prefer fetchAndReschedule-style context switches to yield ones)
-  ; if node_points 
-    then granFetchAndReschedule [] node_points 
-    else granYield             [] node_points
-
-        -- Stack and/or heap checks
-  ; thunkEntryChecks closure_info $ do
-       {
-          -- Overwrite with black hole if necessary
-        ; whenC (blackHoleOnEntry closure_info && node_points)
-               (blackHoleIt closure_info)
-       ; setupUpdate closure_info thunk_code }
-               -- setupUpdate *encloses* the thunk_code
-  }
-
-funWrapper :: ClosureInfo      -- Closure whose code body this is
-          -> [(Id,GlobalReg)]  -- List of argument registers (if any)
-          -> CmmStmts          -- reg saves for the heap check failure
-          -> Code              -- Body of function being compiled
-          -> Code
-funWrapper closure_info arg_regs reg_save_code fun_body = do
-  { dflags <- getDynFlags
-  ; let node_points = nodeMustPointToIt dflags (closureLFInfo closure_info)
-        live        = Just $ map snd arg_regs
-
-  {-
-        -- Debugging: check that R1 has the correct tag
-  ; let tag = funTag closure_info
-  ; whenC (tag /= 0 && node_points) $ do
-        l <- newLabelC
-        stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
-                                                   mkIntExpr dflags tag)]) l)
-        stmtC (CmmStore (CmmLit (mkWordCLit 0)) (mkWordExpr 0))
-        labelC l
-  -}
-
-       -- Enter for Ldv profiling
-  ; whenC node_points (ldvEnterClosure closure_info)
-
-       -- GranSim yeild poin
-  ; granYield arg_regs node_points
-
-        -- Heap and/or stack checks wrap the function body
-  ; funEntryChecks closure_info reg_save_code live fun_body
-  }
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
-%*                                                                     *
-%************************************************************************
-
-
-\begin{code}
-blackHoleIt :: ClosureInfo -> Code
--- Only called for closures with no args
--- Node points to the closure
-blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
-
-emitBlackHoleCode :: Bool -> Code
-emitBlackHoleCode is_single_entry = do
-  dflags <- getDynFlags
-
-  -- Eager blackholing is normally disabled, but can be turned on with
-  -- -feager-blackholing.  When it is on, we replace the info pointer
-  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
-  
-  -- If we wanted to do eager blackholing with slop filling, we'd need
-  -- to do it at the *end* of a basic block, otherwise we overwrite
-  -- the free variables in the thunk that we still need.  We have a
-  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
-  -- [6/2004]
-  --
-  -- Previously, eager blackholing was enabled when ticky-ticky was
-  -- on. But it didn't work, and it wasn't strictly necessary to bring
-  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
-  -- unconditionally disabled. -- krc 1/2007
-  
-  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
-  -- because emitBlackHoleCode is called from CmmParse.
-
-  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)
-                         && gopt Opt_EagerBlackHoling dflags
-             -- Profiling needs slop filling (to support LDV
-             -- profiling), so currently eager blackholing doesn't
-             -- work with profiling.
-
-  whenC eager_blackholing $ do
-    tickyBlackHole (not is_single_entry)
-    stmtsC [
-       CmmStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags))
-                (CmmReg (CmmGlobal CurrentTSO)),
-       CmmCall (CmmPrim MO_WriteBarrier Nothing) [] [] CmmMayReturn,
-       CmmStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
-     ]
-\end{code}
-
-\begin{code}
-setupUpdate :: ClosureInfo -> Code -> Code     -- Only called for closures with no args
-       -- Nota Bene: this function does not change Node (even if it's a CAF),
-       -- so that the cost centre in the original closure can still be
-       -- extracted by a subsequent enterCostCentre
-setupUpdate closure_info code
-  | closureReEntrant closure_info
-  = code
-
-  | not (isStaticClosure closure_info)
-  = do
-   if not (closureUpdReqd closure_info)
-      then do tickyUpdateFrameOmitted; code
-      else do
-          tickyPushUpdateFrame
-          dflags <- getDynFlags
-          if blackHoleOnEntry closure_info &&
-             not (gopt Opt_SccProfilingOn dflags) &&
-             gopt Opt_EagerBlackHoling dflags
-               then pushBHUpdateFrame (CmmReg nodeReg) code
-               else pushUpdateFrame   (CmmReg nodeReg) code
-  
-  | otherwise  -- A static closure
-  = do         { tickyUpdateBhCaf closure_info
-
-       ; if closureUpdReqd closure_info
-         then do       -- Blackhole the (updatable) CAF:
-               { upd_closure <- link_caf closure_info True
-               ; pushBHUpdateFrame upd_closure code }
-         else do
-               { -- krc: removed some ticky-related code here.
-               ; tickyUpdateFrameOmitted
-               ; code }
-    }
-
-
------------------------------------------------------------------------------
--- Entering a CAF
---
--- When a CAF is first entered, it creates a black hole in the heap,
--- and updates itself with an indirection to this new black hole.
---
--- We update the CAF with an indirection to a newly-allocated black
--- hole in the heap.  We also set the blocking queue on the newly
--- allocated black hole to be empty.
---
--- Why do we make a black hole in the heap when we enter a CAF?
---    
---     - for a  generational garbage collector, which needs a fast
---       test for whether an updatee is in an old generation or not
---
---     - for the parallel system, which can implement updates more
---       easily if the updatee is always in the heap. (allegedly).
---
--- When debugging, we maintain a separate CAF list so we can tell when
--- a CAF has been garbage collected.
-
--- newCAF must be called before the itbl ptr is overwritten, since
--- newCAF records the old itbl ptr in order to do CAF reverting
--- (which Hugs needs to do in order that combined mode works right.)
---
-
--- ToDo [Feb 04]  This entire link_caf nonsense could all be moved
--- into the "newCAF" RTS procedure, which we call anyway, including
--- the allocation of the black-hole indirection closure.
--- That way, code size would fall, the CAF-handling code would 
--- be closer together, and the compiler wouldn't need to know
--- about off_indirectee etc.
-
-link_caf :: ClosureInfo
-        -> Bool                -- True <=> updatable, False <=> single-entry
-         -> FCode CmmExpr       -- Returns amode for closure to be updated
--- To update a CAF we must allocate a black hole, link the CAF onto the
--- CAF list, then update the CAF to point to the fresh black hole.
--- This function returns the address of the black hole, so it can be
--- updated with the new value when available.  The reason for all of this
--- is that we only want to update dynamic heap objects, not static ones,
--- so that generational GC is easier.
-link_caf cl_info _is_upd = do
-  { dflags    <- getDynFlags
-    -- Alloc black hole specifying CC_HDR(Node) as the cost centre
-  ; let        use_cc   = costCentreFrom dflags (CmmReg nodeReg)
-        blame_cc = use_cc
-        tso      = CmmReg (CmmGlobal CurrentTSO)
-  ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc
-                                 [(tso, fixedHdrSize dflags)]
-  ; hp_rel    <- getHpRelOffset hp_offset
-
-       -- Call the RTS function newCAF to add the CAF to the CafList
-       -- so that the garbage collector can find them
-       -- This must be done *before* the info table pointer is overwritten, 
-       -- because the old info table ptr is needed for reversion
-  ; ret <- newTemp (bWord dflags)
-  ; emitRtsCallGen [CmmHinted ret NoHint] rtsPackageId (fsLit "newCAF")
-      [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
-        CmmHinted (CmmReg nodeReg) AddrHint,
-        CmmHinted hp_rel AddrHint ]
-      (Just [node])
-       -- node is live, so save it.
-
-  -- see Note [atomic CAF entry] in rts/sm/Storage.c
-  ; emitIf (CmmMachOp (mo_wordEq dflags) [ CmmReg (CmmLocal ret), zeroExpr dflags]) $
-        -- re-enter R1.  Doing this directly is slightly dodgy; we're
-        -- assuming lots of things, like the stack pointer hasn't
-        -- moved since we entered the CAF.
-        let target = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg)) in
-        stmtC (CmmJump target $ Just [node])
-
-  ; returnFC hp_rel }
-  where
-    bh_cl_info :: ClosureInfo
-    bh_cl_info = cafBlackHoleClosureInfo cl_info
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection[CgClosure-Description]{Profiling Closure Description.}
-%*                                                                     *
-%************************************************************************
-
-For "global" data constructors the description is simply occurrence
-name of the data constructor itself.  Otherwise it is determined by
-@closureDescription@ from the let binding information.
-
-\begin{code}
-closureDescription :: DynFlags
-                   -> Module    -- Module
-                   -> Name      -- Id of closure binding
-                   -> String
-       -- Not called for StgRhsCon which have global info tables built in
-       -- CgConTbls.lhs with a description generated from the data constructor
-closureDescription dflags mod_name name
-  = showSDocDumpOneLine dflags (char '<' <>
-                   (if isExternalName name
-                     then ppr name -- ppr will include the module name prefix
-                     else pprModule mod_name <> char '.' <> ppr name) <>
-                   char '>')
-   -- showSDocDumpOneLine, because we want to see the unique on the Name.
-\end{code}
-  
diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
deleted file mode 100644 (file)
index abb280f..0000000
+++ /dev/null
@@ -1,490 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP Project, Glasgow University, 1992-1998
-%
-\section[CgCon]{Code generation for constructors}
-
-This module provides the support code for @StgToAbstractC@ to deal
-with {\em constructors} on the RHSs of let(rec)s.  See also
-@CgClosure@, which deals with closures.
-
-\begin{code}
-module CgCon (
-        cgTopRhsCon, buildDynCon,
-        bindConArgs, bindUnboxedTupleComponents,
-        cgReturnDataCon,
-        cgTyCon
-    ) where
-
-#include "HsVersions.h"
-
-import CgMonad
-import StgSyn
-
-import CgBindery
-import CgStackery
-import CgUtils
-import CgCallConv
-import CgHeapery
-import CgTailCall
-import CgProf
-import CgTicky
-import CgInfoTbls
-import CLabel
-import ClosureInfo
-import OldCmmUtils
-import OldCmm
-import SMRep
-import CostCentre
-import TyCon
-import DataCon
-import Id
-import IdInfo
-import Type
-import PrelInfo
-import Outputable
-import ListSetOps
-import Util
-import Module
-import DynFlags
-import FastString
-import Platform
-
-import Control.Monad
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection[toplevel-constructors]{Top-level constructors}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-cgTopRhsCon :: Id               -- Name of thing bound to this RHS
-            -> DataCon          -- Id
-            -> [StgArg]         -- Args
-            -> FCode (Id, CgIdInfo)
-cgTopRhsCon id con args
-  = do { dflags <- getDynFlags
-        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
-              -- Windows DLLs have a problem with static cross-DLL refs.
-              ASSERT( not (isDllConApp dflags con args) ) return ()
-        ; ASSERT( args `lengthIs` dataConRepRepArity con ) return ()
-
-        -- LAY IT OUT
-        ; amodes <- getArgAmodes args
-
-        ; let
-            name          = idName id
-            lf_info       = mkConLFInfo con
-            closure_label = mkClosureLabel name $ idCafInfo id
-            caffy         = any stgArgHasCafRefs args
-            (closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes
-            closure_rep = mkStaticClosureFields
-                             dflags
-                             closure_info
-                             dontCareCCS                -- Because it's static data
-                             caffy                      -- Has CAF refs
-                             payload
-
-            payload = map get_lit amodes_w_offsets
-            get_lit (CmmLit lit, _offset) = lit
-            get_lit other = pprPanic "CgCon.get_lit" (ppr other)
-                -- NB1: amodes_w_offsets is sorted into ptrs first, then non-ptrs
-                -- NB2: all the amodes should be Lits!
-
-                -- BUILD THE OBJECT
-        ; emitDataLits closure_label closure_rep
-
-                -- RETURN
-        ; returnFC (id, taggedStableIdInfo dflags id (mkLblExpr closure_label) lf_info con) }
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-%* non-top-level constructors                                           *
-%*                                                                      *
-%************************************************************************
-\subsection[code-for-constructors]{The code for constructors}
-
-\begin{code}
-buildDynCon :: Id                 -- Name of the thing to which this constr will
-                                  -- be bound
-            -> CostCentreStack    -- Where to grab cost centre from;
-                                  -- current CCS if currentOrSubsumedCCS
-            -> DataCon            -- The data constructor
-            -> [(CgRep,CmmExpr)]  -- Its args
-            -> FCode CgIdInfo     -- Return details about how to find it
-buildDynCon binder ccs con args
-    = do dflags <- getDynFlags
-         buildDynCon' dflags (targetPlatform dflags) binder ccs con args
-
-buildDynCon' :: DynFlags
-             -> Platform
-             -> Id
-             -> CostCentreStack
-             -> DataCon
-             -> [(CgRep,CmmExpr)]
-             -> FCode CgIdInfo
-
--- We used to pass a boolean indicating whether all the
--- args were of size zero, so we could use a static
--- construtor; but I concluded that it just isn't worth it.
--- Now I/O uses unboxed tuples there just aren't any constructors
--- with all size-zero args.
---
--- The reason for having a separate argument, rather than looking at
--- the addr modes of the args is that we may be in a "knot", and
--- premature looking at the args will cause the compiler to black-hole!
-\end{code}
-
-First we deal with the case of zero-arity constructors.  Now, they
-will probably be unfolded, so we don't expect to see this case much,
-if at all, but it does no harm, and sets the scene for characters.
-
-In the case of zero-arity constructors, or, more accurately, those
-which have exclusively size-zero (VoidRep) args, we generate no code
-at all.
-
-\begin{code}
-buildDynCon' dflags _ binder _ con []
-  = returnFC (taggedStableIdInfo dflags binder
-                           (mkLblExpr (mkClosureLabel (dataConName con)
-                                      (idCafInfo binder)))
-                           (mkConLFInfo con)
-                           con)
-\end{code}
-
-The following three paragraphs about @Char@-like and @Int@-like
-closures are obsolete, but I don't understand the details well enough
-to properly word them, sorry. I've changed the treatment of @Char@s to
-be analogous to @Int@s: only a subset is preallocated, because @Char@
-has now 31 bits. Only literals are handled here. -- Qrczak
-
-Now for @Char@-like closures.  We generate an assignment of the
-address of the closure to a temporary.  It would be possible simply to
-generate no code, and record the addressing mode in the environment,
-but we'd have to be careful if the argument wasn't a constant --- so
-for simplicity we just always asssign to a temporary.
-
-Last special case: @Int@-like closures.  We only special-case the
-situation in which the argument is a literal in the range
-@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
-work with any old argument, but for @Int@-like ones the argument has
-to be a literal.  Reason: @Char@ like closures have an argument type
-which is guaranteed in range.
-
-Because of this, we use can safely return an addressing mode.
-
-We don't support this optimisation when compiling into Windows DLLs yet
-because they don't support cross package data references well.
-
-\begin{code}
-
-
-buildDynCon' dflags platform binder _ con [arg_amode]
-  | maybeIntLikeCon con
-  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
-  , (_, CmmLit (CmmInt val _)) <- arg_amode
-  , let val_int = (fromIntegral val) :: Int
-  , val_int <= mAX_INTLIKE dflags && val_int >= mIN_INTLIKE dflags
-  = do  { let intlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
-              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
-                -- INTLIKE closures consist of a header and one word payload
-              intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW)
-        ; returnFC (taggedStableIdInfo dflags binder intlike_amode (mkConLFInfo con) con) }
-
-buildDynCon' dflags platform binder _ con [arg_amode]
-  | maybeCharLikeCon con
-  , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
-  , (_, CmmLit (CmmInt val _)) <- arg_amode
-  , let val_int = (fromIntegral val) :: Int
-  , val_int <= mAX_CHARLIKE dflags && val_int >= mIN_CHARLIKE dflags
-  = do  { let charlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE")
-              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
-                -- CHARLIKE closures consist of a header and one word payload
-              charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW)
-        ; returnFC (taggedStableIdInfo dflags binder charlike_amode (mkConLFInfo con) con) }
-
-\end{code}
-
-Now the general case.
-
-\begin{code}
-buildDynCon' dflags _ binder ccs con args
-  = do  {
-        ; let
-            (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args
-
-        ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-        ; returnFC (taggedHeapIdInfo dflags binder hp_off lf_info con) }
-  where
-    lf_info = mkConLFInfo con
-
-    use_cc  -- cost-centre to stick in the object
-      | isCurrentCCS ccs = curCCS
-      | otherwise        = panic "buildDynCon: non-current CCS not implemented"
-
-    blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-%* constructor-related utility function:                                *
-%*              bindConArgs is called from cgAlt of a case              *
-%*                                                                      *
-%************************************************************************
-\subsection[constructor-utilities]{@bindConArgs@: constructor-related utility}
-
-@bindConArgs@ $con args$ augments the environment with bindings for the
-binders $args$, assuming that we have just returned from a @case@ which
-found a $con$.
-
-\begin{code}
-bindConArgs :: DataCon -> [Id] -> Code
-bindConArgs con args
-  = do dflags <- getDynFlags
-       let
-          -- The binding below forces the masking out of the tag bits
-          -- when accessing the constructor field.
-          bind_arg (arg, offset) = bindNewToUntagNode arg offset (mkLFArgument arg) (tagForCon dflags con)
-          (_, args_w_offsets)    = layOutDynConstr dflags con (addIdReps args)
-        --
-       ASSERT(not (isUnboxedTupleCon con)) return ()
-       mapCs bind_arg args_w_offsets
-\end{code}
-
-Unboxed tuples are handled slightly differently - the object is
-returned in registers and on the stack instead of the heap.
-
-\begin{code}
-bindUnboxedTupleComponents
-        :: [Id]                         -- Args
-        -> FCode ([(Id,GlobalReg)],     -- Regs assigned
-                  WordOff,              -- Number of pointer stack slots
-                  WordOff,              -- Number of non-pointer stack slots
-                  VirtualSpOffset)      -- Offset of return address slot
-                                        -- (= realSP on entry)
-
-bindUnboxedTupleComponents args
- =  do  {
-          dflags <- getDynFlags
-
-        ; vsp <- getVirtSp
-        ; rsp <- getRealSp
-
-           -- Assign as many components as possible to registers
-        ; let (reg_args, stk_args) = assignReturnRegs dflags (addIdReps args)
-
-                -- Separate the rest of the args into pointers and non-pointers
-              (ptr_args, nptr_args) = separateByPtrFollowness stk_args
-
-                -- Allocate the rest on the stack
-                -- The real SP points to the return address, above which any
-                -- leftover unboxed-tuple components will be allocated
-              (ptr_sp,  ptr_offsets)  = mkVirtStkOffsets dflags rsp    ptr_args
-              (nptr_sp, nptr_offsets) = mkVirtStkOffsets dflags ptr_sp nptr_args
-              ptrs  = ptr_sp  - rsp
-              nptrs = nptr_sp - ptr_sp
-
-            -- The stack pointer points to the last stack-allocated component
-        ; setRealAndVirtualSp nptr_sp
-
-            -- We have just allocated slots starting at real SP + 1, and set the new
-            -- virtual SP to the topmost allocated slot.
-            -- If the virtual SP started *below* the real SP, we've just jumped over
-            -- some slots that won't be in the free-list, so put them there
-            -- This commonly happens because we've freed the return-address slot
-            -- (trimming back the virtual SP), but the real SP still points to that slot
-        ; freeStackSlots [vsp+1,vsp+2 .. rsp]
-
-        ; bindArgsToRegs reg_args
-        ; bindArgsToStack ptr_offsets
-        ; bindArgsToStack nptr_offsets
-
-        ; returnFC (reg_args, ptrs, nptrs, rsp) }
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-        Actually generate code for a constructor return
-%*                                                                      *
-%************************************************************************
-
-
-Note: it's the responsibility of the @cgReturnDataCon@ caller to be
-sure the @amodes@ passed don't conflict with each other.
-\begin{code}
-cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
-
-cgReturnDataCon con amodes = do
-  dflags <- getDynFlags
-  if isUnboxedTupleCon con then returnUnboxedTuple amodes
-  -- when profiling we can't shortcut here, we have to enter the closure
-  -- for it to be marked as "used" for LDV profiling.
-   else if gopt Opt_SccProfilingOn dflags then build_it_then (enter_it dflags)
-   else ASSERT( amodes `lengthIs` dataConRepRepArity con )
-     do { EndOfBlockInfo _ sequel <- getEndOfBlockInfo
-        ; case sequel of
-            CaseAlts _ (Just (alts, deflt_lbl)) bndr
-              ->    -- Ho! We know the constructor so we can
-                    -- go straight to the right alternative
-                 case assocMaybe alts (dataConTagZ con) of {
-                    Just join_lbl -> build_it_then (jump_to join_lbl);
-                    Nothing
-                        -- Special case!  We're returning a constructor to the default case
-                        -- of an enclosing case.  For example:
-                        --
-                        --      case (case e of (a,b) -> C a b) of
-                        --        D x -> ...
-                        --        y   -> ...<returning here!>...
-                        --
-                        -- In this case,
-                        --      if the default is a non-bind-default (ie does not use y),
-                        --      then we should simply jump to the default join point;
-
-                        | isDeadBinder bndr -> performReturn (jump_to deflt_lbl)
-                        | otherwise         -> build_it_then (jump_to deflt_lbl) }
-
-            _otherwise  -- The usual case
-              -> build_it_then $ emitReturnInstr node_live
-        }
-  where
-    node_live   = Just [node]
-    enter_it dflags
-                = stmtsC [ CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg)),
-                           CmmJump (entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg)
-                                   node_live
-                         ]
-    jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live
-    build_it_then return_code
-      = do {    -- BUILD THE OBJECT IN THE HEAP
-                -- The first "con" says that the name bound to this
-                -- closure is "con", which is a bit of a fudge, but it only
-                -- affects profiling
-
-                -- This Id is also used to get a unique for a
-                -- temporary variable, if the closure is a CHARLIKE.
-                -- funnily enough, this makes the unique always come
-                -- out as '54' :-)
-             tickyReturnNewCon (length amodes)
-           ; idinfo <- buildDynCon (dataConWorkId con) currentCCS con amodes
-           ; amode <- idInfoToAmode idinfo
-           ; checkedAbsC (CmmAssign nodeReg amode)
-           ; performReturn return_code }
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-        Generating static stuff for algebraic data types
-%*                                                                      *
-%************************************************************************
-
-        [These comments are rather out of date]
-
-\begin{tabular}{lll}
-Info tbls &      Macro  &            Kind of constructor \\
-\hline
-info & @CONST_INFO_TABLE@&    Zero arity (no info -- compiler uses static closure)\\
-info & @CHARLIKE_INFO_TABLE@& Charlike   (no info -- compiler indexes fixed array)\\
-info & @INTLIKE_INFO_TABLE@&  Intlike; the one macro generates both info tbls\\
-info & @SPEC_INFO_TABLE@&     SPECish, and bigger than or equal to @MIN_UPD_SIZE@\\
-info & @GEN_INFO_TABLE@&      GENish (hence bigger than or equal to @MIN_UPD_SIZE@)\\
-\end{tabular}
-
-Possible info tables for constructor con:
-
-\begin{description}
-\item[@_con_info@:]
-Used for dynamically let(rec)-bound occurrences of
-the constructor, and for updates.  For constructors
-which are int-like, char-like or nullary, when GC occurs,
-the closure tries to get rid of itself.
-
-\item[@_static_info@:]
-Static occurrences of the constructor
-macro: @STATIC_INFO_TABLE@.
-\end{description}
-
-For zero-arity constructors, \tr{con}, we NO LONGER generate a static closure;
-it's place is taken by the top level defn of the constructor.
-
-For charlike and intlike closures there is a fixed array of static
-closures predeclared.
-
-\begin{code}
-cgTyCon :: TyCon -> FCode CmmGroup  -- each constructor gets a separate CmmGroup
-cgTyCon tycon
-  = do  { dflags <- getDynFlags
-        ; constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
-
-            -- Generate a table of static closures for an enumeration type
-            -- Put the table after the data constructor decls, because the
-            -- datatype closure table (for enumeration types)
-            -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
-            -- Note that the closure pointers are tagged.
-
-            -- XXX comment says to put table after constructor decls, but
-            -- code appears to put it before --- NR 16 Aug 2007
-        ; extra <-
-           if isEnumerationTyCon tycon then do
-                tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
-                           [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon dflags con)
-                           | con <- tyConDataCons tycon])
-                return [tbl]
-           else
-                return []
-
-        ; return (concat (extra ++ constrs))
-    }
-\end{code}
-
-Generate the entry code, info tables, and (for niladic constructor) the
-static closure, for a constructor.
-
-\begin{code}
-cgDataCon :: DataCon -> Code
-cgDataCon data_con
-  = do  { dflags <- getDynFlags
-        -- Don't need any dynamic closure code for zero-arity constructors
-
-        ; let
-            -- To allow the debuggers, interpreters, etc to cope with
-            -- static data structures (ie those built at compile
-            -- time), we take care that info-table contains the
-            -- information we need.
-            (static_cl_info, _) =
-                layOutStaticConstr dflags data_con arg_reps
-
-            (dyn_cl_info, arg_things) =
-                layOutDynConstr    dflags data_con arg_reps
-
-            emit_info cl_info ticky_code
-                = do { code_blks <- getCgStmts the_code
-                     ; emitClosureCodeAndInfoTable cl_info [] code_blks }
-                where
-                  the_code = do { _ <- ticky_code
-                                ; ldvEnter (CmmReg nodeReg)
-                                ; body_code }
-
-            arg_reps :: [(CgRep, UnaryType)]
-            arg_reps = [(typeCgRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
-
-            body_code = do {
-                        -- NB: We don't set CC when entering data (WDP 94/06)
-                             tickyReturnOldCon (length arg_things)
-                           -- The case continuation code is expecting a tagged pointer
-                           ; stmtC (CmmAssign nodeReg
-                                              (tagCons dflags data_con (CmmReg nodeReg)))
-                           ; performReturn $ emitReturnInstr (Just []) }
-                                -- noStmts: Ptr to thing already in Node
-
-        ; whenC (not (isNullaryRepDataCon data_con))
-                (emit_info dyn_cl_info tickyEnterDynCon)
-
-                -- Dynamic-Closure first, to reduce forward references
-        ; emit_info static_cl_info tickyEnterStaticCon }
-\end{code}
diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
deleted file mode 100644 (file)
index 70fb600..0000000
+++ /dev/null
@@ -1,496 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-
-\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgExpr ( cgExpr ) where
-
-#include "HsVersions.h"
-
-import StgSyn
-import CgMonad
-
-import CostCentre
-import SMRep
-import CoreSyn
-import CgProf
-import CgHeapery
-import CgBindery
-import CgCase
-import CgClosure
-import CgCon
-import CgLetNoEscape
-import CgTailCall
-import CgInfoTbls
-import CgForeignCall
-import CgPrimOp
-import CgHpc
-import CgUtils
-import ClosureInfo
-import OldCmm
-import OldCmmUtils
-import VarSet
-import Literal
-import PrimOp
-import Id
-import TyCon
-import Type
-import Maybes
-import ListSetOps
-import BasicTypes
-import Util
-import DynFlags
-import Outputable
-\end{code}
-
-This module provides the support code for @StgToAbstractC@ to deal
-with STG {\em expressions}.  See also @CgClosure@, which deals
-with closures, and @CgCon@, which deals with constructors.
-
-\begin{code}
-cgExpr :: StgExpr              -- input
-       -> Code                 -- output
-\end{code}
-
-%********************************************************
-%*                                                     *
-%*             Tail calls                              *
-%*                                                     *
-%********************************************************
-
-``Applications'' mean {\em tail calls}, a service provided by module
-@CgTailCall@.  This includes literals, which show up as
-@(STGApp (StgLitArg 42) [])@.
-
-\begin{code}
-cgExpr (StgApp fun args) = cgTailCall fun args
-\end{code}
-
-%********************************************************
-%*                                                     *
-%*             STG ConApps  (for inline versions)      *
-%*                                                     *
-%********************************************************
-
-\begin{code}
-cgExpr (StgConApp con args)
-  = do { amodes <- getArgAmodes args
-       ; cgReturnDataCon con amodes }
-\end{code}
-
-Literals are similar to constructors; they return by putting
-themselves in an appropriate register and returning to the address on
-top of the stack.
-
-\begin{code}
-cgExpr (StgLit lit)
-  = do  { cmm_lit <- cgLit lit
-       ; performPrimReturn rep (CmmLit cmm_lit) }
-  where
-    rep = (typeCgRep) (literalType lit)
-\end{code}
-
-
-%********************************************************
-%*                                                     *
-%*     PrimOps and foreign calls.
-%*                                                     *
-%********************************************************
-
-NOTE about "safe" foreign calls: a safe foreign call is never compiled
-inline in a case expression.  When we see
-
-       case (ccall ...) of { ... }
-
-We generate a proper return address for the alternatives and push the
-stack frame before doing the call, so that in the event that the call
-re-enters the RTS the stack is in a sane state.
-
-\begin{code}
-cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
-    dflags <- getDynFlags
-    {-
-       First, copy the args into temporaries.  We're going to push
-       a return address right before doing the call, so the args
-       must be out of the way.
-    -}
-    reps_n_amodes <- getArgAmodes stg_args
-    let 
-       -- Get the *non-void* args, and jiggle them with shimForeignCall
-       arg_exprs = [ (shimForeignCallArg dflags stg_arg expr, stg_arg)
-                   | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, 
-                     nonVoidArg rep]
-
-    arg_tmps <- sequence [ assignTemp arg
-                         | (arg, _) <- arg_exprs]
-    let        arg_hints = zipWith CmmHinted arg_tmps (map (typeForeignHint.stgArgType) stg_args)
-    {-
-       Now, allocate some result regs.
-    -}
-    (res_reps,res_regs,res_hints)  <- newUnboxedTupleRegs res_ty
-    ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $
-       emitForeignCall (zipWith CmmHinted res_regs res_hints) fcall 
-          arg_hints emptyVarSet{-no live vars-}
-      
--- tagToEnum# is special: we need to pull the constructor out of the table,
--- and perform an appropriate return.
-
-cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) 
-  = ASSERT(isEnumerationTyCon tycon)
-    do { dflags <- getDynFlags
-        ; (_rep,amode) <- getArgAmode arg
-       ; amode' <- assignTemp amode    -- We're going to use it twice,
-                                       -- so save in a temp if non-trivial
-       ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode'))
-       ; performReturn $ emitReturnInstr (Just [node]) }
-   where
-         -- If you're reading this code in the attempt to figure
-         -- out why the compiler panic'ed here, it is probably because
-         -- you used tagToEnum# in a non-monomorphic setting, e.g., 
-         --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
-         -- That won't work.
-       tycon = tyConAppTyCon res_ty
-
-
-cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty)
-  = cgTailCall a []
-  -- seq# :: a -> State# -> (# State# , a #)
-  -- but the return convention for (# State#, a #) is exactly the same as
-  -- for just a, so we can implment seq# by
-  --   seq# a s  ==>  a
-
-cgExpr (StgOpApp (StgPrimOp primop) args res_ty)
-  | primOpOutOfLine primop
-       = tailCallPrimOp primop args
-
-  | ReturnsPrim VoidRep <- result_info
-       = do cgPrimOp [] primop args emptyVarSet
-             -- ToDo: STG Live -- worried about this
-            performReturn $ emitReturnInstr (Just [])
-
-  | ReturnsPrim rep <- result_info
-        = do dflags <- getDynFlags
-             res <- newTemp (typeCmmType dflags res_ty)
-             cgPrimOp [res] primop args emptyVarSet
-            performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res))
-
-  | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
-       = do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
-            cgPrimOp regs primop args emptyVarSet{-no live vars-}
-            returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs))
-
-  | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
-       -- c.f. cgExpr (...TagToEnumOp...)
-       = do dflags <- getDynFlags
-            tag_reg <- newTemp (bWord dflags) -- The tag is a word
-            cgPrimOp [tag_reg] primop args emptyVarSet
-            stmtC (CmmAssign nodeReg
-                    (tagToClosure dflags tycon
-                     (CmmReg (CmmLocal tag_reg))))
-             -- ToDo: STG Live -- worried about this
-            performReturn $ emitReturnInstr (Just [node])
-  where
-       result_info = getPrimOpResultInfo primop
-
-cgExpr (StgOpApp (StgPrimCallOp primcall) args _res_ty)
-  = tailCallPrimCall primcall args
-\end{code}
-
-%********************************************************
-%*                                                     *
-%*             Case expressions                        *
-%*                                                     *
-%********************************************************
-Case-expression conversion is complicated enough to have its own
-module, @CgCase@.
-\begin{code}
-
-cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
-  = setSRT srt $ cgCase expr live_vars save_vars bndr alt_type alts
-\end{code}
-
-
-%********************************************************
-%*                                                     *
-%*             Let and letrec                          *
-%*                                                     *
-%********************************************************
-\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
-
-\begin{code}
-cgExpr (StgLet (StgNonRec name rhs) expr)
-  = cgRhs name rhs     `thenFC` \ (name, info) ->
-    addBindC name info         `thenC`
-    cgExpr expr
-
-cgExpr (StgLet (StgRec pairs) expr)
-  = fixC (\ new_bindings -> addBindsC new_bindings `thenC`
-                           listFCs [ cgRhs b e | (b,e) <- pairs ]
-    ) `thenFC` \ new_bindings ->
-
-    addBindsC new_bindings `thenC`
-    cgExpr expr
-\end{code}
-
-\begin{code}
-cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
-  = do {       -- Figure out what volatile variables to save
-       ; nukeDeadBindings live_in_whole_let
-       ; (save_assts, rhs_eob_info, maybe_cc_slot) 
-               <- saveVolatileVarsAndRegs live_in_rhss
-
-       -- Save those variables right now!
-       ; emitStmts save_assts
-
-       -- Produce code for the rhss
-       -- and add suitable bindings to the environment
-       ; cgLetNoEscapeBindings live_in_rhss rhs_eob_info 
-                               maybe_cc_slot bindings
-
-       -- Do the body
-       ; setEndOfBlockInfo rhs_eob_info (cgExpr body) }
-\end{code}
-
-
-%********************************************************
-%*                                                     *
-%*             SCC Expressions                         *
-%*                                                     *
-%********************************************************
-
-SCC expressions are treated specially. They set the current cost
-centre.
-
-\begin{code}
-cgExpr (StgSCC cc tick push expr) = do emitSetCCC cc tick push; cgExpr expr
-\end{code}
-
-%********************************************************
-%*                                                     *
-%*             Hpc Tick Boxes                          *
-%*                                                     *
-%********************************************************
-
-\begin{code}
-cgExpr (StgTick m n expr) = do cgTickBox m n; cgExpr expr
-\end{code}
-
-%********************************************************
-%*                                                     *
-%*             Anything else                           *
-%*                                                     *
-%********************************************************
-
-\begin{code}
-cgExpr _ = panic "cgExpr"
-\end{code}
-
-%********************************************************
-%*                                                     *
-%*             Non-top-level bindings                  *
-%*                                                     *
-%********************************************************
-\subsection[non-top-level-bindings]{Converting non-top-level bindings}
-
-We rely on the support code in @CgCon@ (to do constructors) and
-in @CgClosure@ (to do closures).
-
-\begin{code}
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-       -- the Id is passed along so a binding can be set up
-
-cgRhs name (StgRhsCon maybe_cc con args)
-  = do { amodes <- getArgAmodes args
-       ; idinfo <- buildDynCon name maybe_cc con amodes
-       ; returnFC (name, idinfo) }
-
-cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
-  = do dflags <- getDynFlags
-       setSRT srt $ mkRhsClosure dflags name cc bi fvs upd_flag args body
-\end{code}
-
-mkRhsClosure looks for two special forms of the right-hand side:
-       a) selector thunks.
-       b) AP thunks
-
-If neither happens, it just calls mkClosureLFInfo.  You might think
-that mkClosureLFInfo should do all this, but it seems wrong for the
-latter to look at the structure of an expression
-
-Selectors
-~~~~~~~~~
-We look at the body of the closure to see if it's a selector---turgid,
-but nothing deep.  We are looking for a closure of {\em exactly} the
-form:
-
-...  = [the_fv] \ u [] ->
-        case the_fv of
-          con a_1 ... a_n -> a_i
-
-
-\begin{code}
-mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
-             -> [Id] -> UpdateFlag -> [Id] -> GenStgExpr Id Id
-             -> FCode (Id, CgIdInfo)
-mkRhsClosure   dflags bndr cc bi
-               [the_fv]                -- Just one free var
-               upd_flag                -- Updatable thunk
-               []                      -- A thunk
-               body@(StgCase (StgApp scrutinee [{-no args-}])
-                     _ _ _ srt   -- ignore uniq, etc.
-                     (AlgAlt _)
-                     [(DataAlt con, params, _use_mask,
-                           (StgApp selectee [{-no args-}]))])
-  |  the_fv == scrutinee               -- Scrutinee is the only free variable
-  && maybeToBool maybe_offset          -- Selectee is a component of the tuple
-  && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
-  = -- NOT TRUE: ASSERT(is_single_constructor)
-    -- The simplifier may have statically determined that the single alternative
-    -- is the only possible case and eliminated the others, even if there are
-    -- other constructors in the datatype.  It's still ok to make a selector
-    -- thunk in this case, because we *know* which constructor the scrutinee
-    -- will evaluate to.
-    setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
-  where
-    lf_info              = mkSelectorLFInfo bndr offset_into_int
-                                (isUpdatable upd_flag)
-    (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params)
-                       -- Just want the layout
-    maybe_offset         = assocMaybe params_w_offsets selectee
-    Just the_offset      = maybe_offset
-    offset_into_int       = the_offset - fixedHdrSize dflags
-\end{code}
-
-Ap thunks
-~~~~~~~~~
-
-A more generic AP thunk of the form
-
-       x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
-
-A set of these is compiled statically into the RTS, so we just use
-those.  We could extend the idea to thunks where some of the x_i are
-global ids (and hence not free variables), but this would entail
-generating a larger thunk.  It might be an option for non-optimising
-compilation, though.
-
-We only generate an Ap thunk if all the free variables are pointers,
-for semi-obvious reasons.
-
-\begin{code}
-mkRhsClosure dflags bndr cc bi
-               fvs
-               upd_flag
-               []                      -- No args; a thunk
-               body@(StgApp fun_id args)
-
-  | args `lengthIs` (arity-1)
-       && all isFollowableArg (map idCgRep fvs) 
-       && isUpdatable upd_flag
-       && arity <= mAX_SPEC_AP_SIZE dflags
-        && not (gopt Opt_SccProfilingOn dflags)
-                                  -- not when profiling: we don't want to
-                                  -- lose information about this particular
-                                  -- thunk (e.g. its type) (#949)
-
-                  -- Ha! an Ap thunk
-       = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload
-
-   where
-       lf_info = mkApLFInfo bndr upd_flag arity
-       -- the payload has to be in the correct order, hence we can't
-       -- just use the fvs.
-       payload = StgVarArg fun_id : args
-       arity   = length fvs
-\end{code}
-
-The default case
-~~~~~~~~~~~~~~~~
-\begin{code}
-mkRhsClosure _ bndr cc bi fvs upd_flag args body
-  = cgRhsClosure bndr cc bi fvs upd_flag args body
-\end{code}
-
-
-%********************************************************
-%*                                                     *
-%*             Let-no-escape bindings
-%*                                                     *
-%********************************************************
-\begin{code}
-cgLetNoEscapeBindings :: StgLiveVars -> EndOfBlockInfo
-                      -> Maybe VirtualSpOffset -> GenStgBinding Id Id
-                      -> Code
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot 
-       (StgNonRec binder rhs)
-  = do { (binder,info) <- cgLetNoEscapeRhs live_in_rhss rhs_eob_info 
-                                           maybe_cc_slot       
-                                           NonRecursive binder rhs 
-       ; addBindC binder info }
-
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
-  = do { new_bindings <- fixC (\ new_bindings -> do
-               { addBindsC new_bindings
-               ; listFCs [ cgLetNoEscapeRhs full_live_in_rhss 
-                               rhs_eob_info maybe_cc_slot Recursive b e 
-                         | (b,e) <- pairs ] })
-
-       ; addBindsC new_bindings }
-  where
-    -- We add the binders to the live-in-rhss set so that we don't
-    -- delete the bindings for the binder from the environment!
-    full_live_in_rhss = live_in_rhss `unionVarSet` (mkVarSet [b | (b,_) <- pairs])
-
-cgLetNoEscapeRhs
-    :: StgLiveVars     -- Live in rhss
-    -> EndOfBlockInfo
-    -> Maybe VirtualSpOffset
-    -> RecFlag
-    -> Id
-    -> StgRhs
-    -> FCode (Id, CgIdInfo)
-
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
-                (StgRhsClosure cc bi _ _upd_flag srt args body)
-  = -- We could check the update flag, but currently we don't switch it off
-    -- for let-no-escaped things, so we omit the check too!
-    -- case upd_flag of
-    --     Updatable -> panic "cgLetNoEscapeRhs"       -- Nothing to update!
-    --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
-    setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info
-       maybe_cc_slot rec args body
-
--- For a constructor RHS we want to generate a single chunk of code which
--- can be jumped to from many places, which will return the constructor.
--- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
-                (StgRhsCon cc con args)
-  = setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-}
-                        full_live_in_rhss rhs_eob_info maybe_cc_slot rec
-       []      --No args; the binder is data structure, not a function
-       (StgConApp con args)
-\end{code}
-
-Little helper for primitives that return unboxed tuples.
-
-\begin{code}
-newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [ForeignHint])
-newUnboxedTupleRegs res_ty = do
-   dflags <- getDynFlags
-   let
-       UbxTupleRep ty_args = repType res_ty
-       (reps,hints) = unzip [ (rep, typeForeignHint ty) | ty <- ty_args,
-                                                   let rep = typeCgRep ty,
-                                                   nonVoidArg rep ]
-       make_new_temp rep = newTemp (argMachRep dflags rep)
-   regs <- mapM make_new_temp reps
-   return (reps,regs,hints)
-\end{code}
diff --git a/compiler/codeGen/CgExpr.lhs-boot b/compiler/codeGen/CgExpr.lhs-boot
deleted file mode 100644 (file)
index 29cdc3a..0000000
+++ /dev/null
@@ -1,7 +0,0 @@
-\begin{code}
-module CgExpr where
-import StgSyn( StgExpr )
-import CgMonad( Code )
-
-cgExpr :: StgExpr -> Code
-\end{code}
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
deleted file mode 100644 (file)
index b0e6516..0000000
+++ /dev/null
@@ -1,322 +0,0 @@
------------------------------------------------------------------------------
---
--- Code generation for foreign calls.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module CgForeignCall (
-        cgForeignCall,
-        emitForeignCall,
-        emitForeignCall',
-        shimForeignCallArg,
-        emitSaveThreadState, -- will be needed by the Cmm parser
-        emitLoadThreadState, -- ditto
-        emitCloseNursery,
-        emitOpenNursery,
-    ) where
-
-import StgSyn
-import CgProf
-import CgBindery
-import CgMonad
-import CgUtils
-import Type
-import TysPrim
-import ClosureInfo( nonVoidArg )
-import CLabel
-import OldCmm
-import OldCmmUtils
-import SMRep
-import ForeignCall
-import DynFlags
-import Outputable
-import Module
-import FastString
-import BasicTypes
-
-import Control.Monad
-
--- -----------------------------------------------------------------------------
--- Code generation for Foreign Calls
-
-cgForeignCall
-        :: [HintedCmmFormal]    -- where to put the results
-        -> ForeignCall          -- the op
-        -> [StgArg]             -- arguments
-        -> StgLiveVars  -- live vars, in case we need to save them
-        -> Code
-cgForeignCall results fcall stg_args live
-  = do
-  reps_n_amodes <- getArgAmodes stg_args
-  dflags <- getDynFlags
-  let
-        -- Get the *non-void* args, and jiggle them with shimForeignCall
-        arg_exprs = [ shimForeignCallArg dflags stg_arg expr
-                    | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
-                       nonVoidArg rep]
-
-        arg_hints = zipWith CmmHinted
-                      arg_exprs (map (typeForeignHint.stgArgType) stg_args)
-  emitForeignCall results fcall arg_hints live
-
-
-emitForeignCall
-        :: [HintedCmmFormal]    -- where to put the results
-        -> ForeignCall          -- the op
-        -> [CmmHinted CmmExpr] -- arguments
-        -> StgLiveVars  -- live vars, in case we need to save them
-        -> Code
-
-emitForeignCall results (CCall (CCallSpec target cconv safety)) args live = do
-  dflags <- getDynFlags
-  let (call_args, cmm_target)
-        = case target of
-           StaticTarget _   _      False ->
-               panic "emitForeignCall: unexpected FFI value import"
-           -- If the packageId is Nothing then the label is taken to be in the
-           --   package currently being compiled.
-           StaticTarget lbl mPkgId True
-            -> let labelSource
-                        = case mPkgId of
-                                Nothing         -> ForeignLabelInThisPackage
-                                Just pkgId      -> ForeignLabelInPackage pkgId
-               in ( args
-                  , CmmLit (CmmLabel
-                                (mkForeignLabel lbl call_size labelSource IsFunction)))
-
-           -- A label imported with "foreign import ccall "dynamic" ..."
-           --   Note: "dynamic" here doesn't mean "dynamic library".
-           --   Read the FFI spec for details.
-           DynamicTarget    ->  case args of
-                                (CmmHinted fn _):rest -> (rest, fn)
-                                [] -> panic "emitForeignCall: DynamicTarget []"
-
-        -- in the stdcall calling convention, the symbol needs @size appended
-        -- to it, where size is the total number of bytes of arguments.  We
-        -- attach this info to the CLabel here, and the CLabel pretty printer
-        -- will generate the suffix when the label is printed.
-      call_size
-        | StdCallConv <- cconv = Just (sum (map (arg_size . cmmExprType dflags . hintlessCmm) args))
-        | otherwise            = Nothing
-
-        -- ToDo: this might not be correct for 64-bit API
-      arg_size rep = max (widthInBytes (typeWidth rep)) (wORD_SIZE dflags)
-  vols <- getVolatileRegs live
-  srt <- getSRTInfo
-  emitForeignCall' safety results
-      (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
-
-
--- alternative entry point, used by CmmParse
--- the new code generator has utility function emitCCall and emitPrimCall
--- which should be used instead of this (the equivalent emitForeignCall
--- is not presently exported.)
-emitForeignCall'
-        :: Safety
-        -> [HintedCmmFormal]    -- where to put the results
-        -> CmmCallTarget        -- the op
-        -> [CmmHinted CmmExpr] -- arguments
-        -> Maybe [GlobalReg]    -- live vars, in case we need to save them
-        -> C_SRT                -- the SRT of the calls continuation
-        -> CmmReturnInfo
-        -> Code
-emitForeignCall' safety results target args vols _srt ret
-  | not (playSafe safety) = do
-    dflags <- getDynFlags
-    temp_args <- load_args_into_temps args
-    let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols
-    let caller_load' = if ret == CmmNeverReturns then [] else caller_load
-    stmtsC caller_save
-    stmtC (CmmCall target results temp_args ret)
-    stmtsC caller_load'
-
-  | otherwise = do
-    dflags <- getDynFlags
-    -- Both 'id' and 'new_base' are GCKindNonPtr because they're
-    -- RTS only objects and are not subject to garbage collection
-    id <- newTemp (bWord dflags)
-    new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
-    temp_args <- load_args_into_temps args
-    temp_target <- load_target_into_temp target
-    let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols
-    emitSaveThreadState
-    stmtsC caller_save
-    -- The CmmUnsafe arguments are only correct because this part
-    -- of the code hasn't been moved into the CPS pass yet.
-    -- Once that happens, this function will just emit a (CmmSafe srt) call,
-    -- and the CPS will be the one to convert that
-    -- to this sequence of three CmmUnsafe calls.
-    stmtC (CmmCall (CmmCallee suspendThread CCallConv)
-                        [ CmmHinted id AddrHint ]
-                        [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
-                        , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) (wordWidth dflags))) NoHint]
-                        ret)
-    stmtC (CmmCall temp_target results temp_args ret)
-    stmtC (CmmCall (CmmCallee resumeThread CCallConv)
-                        [ CmmHinted new_base AddrHint ]
-                        [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
-                        ret)
-    -- Assign the result to BaseReg: we
-    -- might now have a different Capability!
-    stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
-    stmtsC caller_load
-    emitLoadThreadState
-
-suspendThread, resumeThread :: CmmExpr
-suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
-resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
-
-
--- we might need to load arguments into temporaries before
--- making the call, because certain global registers might
--- overlap with registers that the C calling convention uses
--- for passing arguments.
---
--- This is a HACK; really it should be done in the back end, but
--- it's easier to generate the temporaries here.
-load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
-load_args_into_temps = mapM arg_assign_temp
-  where arg_assign_temp (CmmHinted e hint) = do
-           tmp <- maybe_assign_temp e
-           return (CmmHinted tmp hint)
-
-load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
-load_target_into_temp (CmmCallee expr conv) = do
-  tmp <- maybe_assign_temp expr
-  return (CmmCallee tmp conv)
-load_target_into_temp other_target =
-  return other_target
-
-maybe_assign_temp :: CmmExpr -> FCode CmmExpr
-maybe_assign_temp e
-  | hasNoGlobalRegs e = return e
-  | otherwise          = do
-        dflags <- getDynFlags
-        -- don't use assignTemp, it uses its own notion of "trivial"
-        -- expressions, which are wrong here.
-        -- this is a NonPtr because it only duplicates an existing
-        reg <- newTemp (cmmExprType dflags e) --TODO FIXME NOW
-        stmtC (CmmAssign (CmmLocal reg) e)
-        return (CmmReg (CmmLocal reg))
-
--- -----------------------------------------------------------------------------
--- Save/restore the thread state in the TSO
-
--- This stuff can't be done in suspendThread/resumeThread, because it
--- refers to global registers which aren't available in the C world.
-
-emitSaveThreadState :: Code
-emitSaveThreadState = do
-  dflags <- getDynFlags
-  -- CurrentTSO->stackobj->sp = Sp;
-  stmtC $ CmmStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags))
-                              (stack_SP dflags)) stgSp
-  emitCloseNursery
-  -- and save the current cost centre stack in the TSO when profiling:
-  when (gopt Opt_SccProfilingOn dflags) $
-        stmtC (CmmStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS)
-
-   -- CurrentNursery->free = Hp+1;
-emitCloseNursery :: Code
-emitCloseNursery = do dflags <- getDynFlags
-                      stmtC $ CmmStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1)
-
-emitLoadThreadState :: Code
-emitLoadThreadState = do
-  dflags <- getDynFlags
-  tso <- newTemp (bWord dflags) -- TODO FIXME NOW
-  stack <- newTemp (bWord dflags) -- TODO FIXME NOW
-  stmtsC [
-        -- tso = CurrentTSO
-        CmmAssign (CmmLocal tso) stgCurrentTSO,
-        -- stack = tso->stackobj
-        CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
-        -- Sp = stack->sp;
-        CmmAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags))
-                              (bWord dflags)),
-        -- SpLim = stack->stack + RESERVED_STACK_WORDS;
-        CmmAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
-                                    (rESERVED_STACK_WORDS dflags)),
-        -- HpAlloc = 0;
-        --   HpAlloc is assumed to be set to non-zero only by a failed
-        --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
-        CmmAssign hpAlloc (CmmLit (zeroCLit dflags))
-    ]
-  emitOpenNursery
-  -- and load the current cost centre stack from the TSO when profiling:
-  when (gopt Opt_SccProfilingOn dflags) $
-        stmtC $ storeCurCCS $
-                  CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (bWord dflags)
-
-emitOpenNursery :: Code
-emitOpenNursery =
-   do dflags <- getDynFlags
-      stmtsC [
-        -- Hp = CurrentNursery->free - 1;
-        CmmAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (gcWord dflags)) (-1)),
-
-        -- HpLim = CurrentNursery->start +
-        --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-        CmmAssign hpLim
-            (cmmOffsetExpr dflags
-                (CmmLoad (nursery_bdescr_start dflags) (bWord dflags))
-                (cmmOffset dflags
-                  (CmmMachOp (mo_wordMul dflags) [
-                    CmmMachOp (MO_SS_Conv W32 (wordWidth dflags))
-                      [CmmLoad (nursery_bdescr_blocks dflags) b32],
-                    mkIntExpr dflags (bLOCK_SIZE dflags)
-                   ])
-                  (-1)
-                )
-            )
-        ]
-
-nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr
-nursery_bdescr_free   dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags)
-nursery_bdescr_start  dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags)
-nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags)
-
-tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
-tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
-tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
-stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)
-stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
-
-closureField :: DynFlags -> ByteOff -> ByteOff
-closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE dflags
-
-stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
-stgSp             = CmmReg sp
-stgHp             = CmmReg hp
-stgCurrentTSO     = CmmReg currentTSO
-stgCurrentNursery = CmmReg currentNursery
-
-sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
-sp                = CmmGlobal Sp
-spLim             = CmmGlobal SpLim
-hp                = CmmGlobal Hp
-hpLim             = CmmGlobal HpLim
-currentTSO        = CmmGlobal CurrentTSO
-currentNursery    = CmmGlobal CurrentNursery
-hpAlloc           = CmmGlobal HpAlloc
-
--- -----------------------------------------------------------------------------
--- For certain types passed to foreign calls, we adjust the actual
--- value passed to the call.  For ByteArray#/Array# we pass the
--- address of the actual array, not the address of the heap object.
-
-shimForeignCallArg :: DynFlags -> StgArg -> CmmExpr -> CmmExpr
-shimForeignCallArg dflags arg expr
-  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
-        = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
-
-  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
-        = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
-
-  | otherwise = expr
-  where
-        -- should be a tycon app, since this is a foreign call
-        UnaryRep rep_ty = repType (stgArgType arg)
-        tycon           = tyConAppTyCon rep_ty
diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs
deleted file mode 100644 (file)
index 8cff773..0000000
+++ /dev/null
@@ -1,642 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgHeapery]{Heap management functions}
-
-\begin{code}
-module CgHeapery (
-        initHeapUsage, getVirtHp, setVirtHp, setRealHp,
-        getHpRelOffset, hpRel,
-
-        funEntryChecks, thunkEntryChecks,
-        altHeapCheck, unbxTupleHeapCheck,
-        hpChkGen, hpChkNodePointsAssignSp0,
-        stkChkGen, stkChkNodePoints,
-
-        layOutDynConstr, layOutStaticConstr,
-        mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
-
-        allocDynClosure, emitSetDynHdr
-    ) where
-
-#include "HsVersions.h"
-
-import StgSyn
-import CLabel
-import CgUtils
-import CgMonad
-import CgProf
-import CgTicky
-import CgParallel
-import CgStackery
-import CgCallConv
-import ClosureInfo
-import SMRep
-
-import OldCmm
-import OldCmmUtils
-import Id
-import DataCon
-import TyCon
-import CostCentre
-import Util
-import Module
-import Outputable
-import DynFlags
-import FastString
-
-import Data.List
-import Data.Maybe (fromMaybe)
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgUsages-heapery]{Monad things for fiddling with heap usage}
-%*                                                                      *
-%************************************************************************
-
-The heap always grows upwards, so hpRel is easy
-
-\begin{code}
-hpRel :: VirtualHpOffset        -- virtual offset of Hp
-      -> VirtualHpOffset        -- virtual offset of The Thing
-      -> WordOff                -- integer word offset
-hpRel hp off = off - hp
-\end{code}
-
-@initHeapUsage@ applies a function to the amount of heap that it uses.
-It initialises the heap usage to zeros, and passes on an unchanged
-heap usage.
-
-It is usually a prelude to performing a GC check, so everything must
-be in a tidy and consistent state.
-
-rje: Note the slightly suble fixed point behaviour needed here
-
-\begin{code}
-initHeapUsage :: (VirtualHpOffset -> Code) -> Code
-initHeapUsage fcode
-  = do  { orig_hp_usage <- getHpUsage
-        ; setHpUsage initHpUsage
-        ; fixC_(\heap_usage2 -> do
-                { fcode (heapHWM heap_usage2)
-                ; getHpUsage })
-        ; setHpUsage orig_hp_usage }
-
-setVirtHp :: VirtualHpOffset -> Code
-setVirtHp new_virtHp
-  = do  { hp_usage <- getHpUsage
-        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
-
-getVirtHp :: FCode VirtualHpOffset
-getVirtHp
-  = do  { hp_usage <- getHpUsage
-        ; return (virtHp hp_usage) }
-
-setRealHp ::  VirtualHpOffset -> Code
-setRealHp new_realHp
-  = do  { hp_usage <- getHpUsage
-        ; setHpUsage (hp_usage {realHp = new_realHp}) }
-
-getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
-getHpRelOffset virtual_offset
-  = do  { dflags <- getDynFlags
-        ; hp_usg <- getHpUsage
-        ; return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset)) }
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-                Layout of heap objects
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-layOutDynConstr, layOutStaticConstr
-        :: DynFlags
-        -> DataCon
-        -> [(CgRep,a)]
-        -> (ClosureInfo,
-            [(a,VirtualHpOffset)])
-
-layOutDynConstr    = layOutConstr False
-layOutStaticConstr = layOutConstr True
-
-layOutConstr :: Bool -> DynFlags -> DataCon -> [(CgRep, a)]
-             -> (ClosureInfo, [(a, VirtualHpOffset)])
-layOutConstr is_static dflags data_con args
-   = (mkConInfo dflags is_static data_con tot_wds ptr_wds,
-      things_w_offsets)
-  where
-    (tot_wds,            --  #ptr_wds + #nonptr_wds
-     ptr_wds,            --  #ptr_wds
-     things_w_offsets) = mkVirtHeapOffsets dflags False{-not a thunk-} args
-\end{code}
-
-@mkVirtHeapOffsets@ always returns boxed things with smaller offsets
-than the unboxed things, and furthermore, the offsets in the result
-list
-
-\begin{code}
-mkVirtHeapOffsets
-          :: DynFlags
-          -> Bool               -- True <=> is a thunk
-          -> [(CgRep,a)]        -- Things to make offsets for
-          -> (WordOff,          -- _Total_ number of words allocated
-              WordOff,          -- Number of words allocated for *pointers*
-              [(a, VirtualHpOffset)])
-                                -- Things with their offsets from start of
-                                --  object in order of increasing offset
-
--- First in list gets lowest offset, which is initial offset + 1.
-
-mkVirtHeapOffsets dflags is_thunk things
-  = let non_void_things               = filterOut (isVoidArg . fst) things
-        (ptrs, non_ptrs)              = separateByPtrFollowness non_void_things
-        (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
-        (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
-    in
-    (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
-  where
-    hdr_size    | is_thunk   = thunkHdrSize dflags
-                | otherwise  = fixedHdrSize dflags
-
-    computeOffset wds_so_far (rep, thing)
-      = (wds_so_far + cgRepSizeW dflags rep, (thing, hdr_size + wds_so_far))
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-                Lay out a static closure
-%*                                                                      *
-%************************************************************************
-
-Make a static closure, adding on any extra padding needed for CAFs,
-and adding a static link field if necessary.
-
-\begin{code}
-mkStaticClosureFields
-        :: DynFlags
-        -> ClosureInfo
-        -> CostCentreStack
-        -> Bool                 -- Has CAF refs
-        -> [CmmLit]             -- Payload
-        -> [CmmLit]             -- The full closure
-mkStaticClosureFields dflags cl_info ccs caf_refs payload
-  = mkStaticClosure dflags info_lbl ccs payload padding_wds
-        static_link_field saved_info_field
-  where
-    info_lbl = infoTableLabelFromCI cl_info
-
-    -- CAFs must have consistent layout, regardless of whether they
-    -- are actually updatable or not.  The layout of a CAF is:
-    --
-    --        3 saved_info
-    --        2 static_link
-    --        1 indirectee
-    --        0 info ptr
-    --
-    -- the static_link and saved_info fields must always be in the same
-    -- place.  So we use closureNeedsUpdSpace rather than
-    -- closureUpdReqd here:
-
-    is_caf = closureNeedsUpdSpace cl_info
-
-    padding_wds
-        | not is_caf = []
-        | otherwise  = ASSERT(null payload) [mkIntCLit dflags 0]
-
-    static_link_field
-        | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
-        | otherwise                                = []
-
-    saved_info_field
-        | is_caf     = [mkIntCLit dflags 0]
-        | otherwise  = []
-
-        -- for a static constructor which has NoCafRefs, we set the
-        -- static link field to a non-zero value so the garbage
-        -- collector will ignore it.
-    static_link_value
-        | caf_refs      = mkIntCLit dflags 0
-        | otherwise     = mkIntCLit dflags 1
-
-mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
-  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure dflags info_lbl ccs payload padding_wds static_link_field saved_info_field
-  =  [CmmLabel info_lbl]
-  ++ variable_header_words
-  ++ concatMap (padLitToWord dflags) payload
-  ++ padding_wds
-  ++ static_link_field
-  ++ saved_info_field
-  where
-    variable_header_words
-        =  staticGranHdr
-        ++ staticParHdr
-        ++ staticProfHdr dflags ccs
-        ++ staticTickyHdr
-
-padLitToWord :: DynFlags -> CmmLit -> [CmmLit]
-padLitToWord dflags lit = lit : padding pad_length
-  where width = typeWidth (cmmLitType dflags lit)
-        pad_length = wORD_SIZE dflags - widthInBytes width :: Int
-
-        padding n | n <= 0 = []
-                  | n `rem` 2 /= 0 = CmmInt 0 W8  : padding (n-1)
-                  | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2)
-                  | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4)
-                  | otherwise      = CmmInt 0 W64 : padding (n-8)
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgHeapery-heap-overflow]{Heap overflow checking}
-%*                                                                      *
-%************************************************************************
-
-The new code  for heapChecks. For GrAnSim the code for doing a heap check
-and doing a context switch has been separated. Especially, the HEAP_CHK
-macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for
-doing a context switch. GRAN_FETCH_AND_RESCHEDULE must be put at the
-beginning of every slow entry code in order to simulate the fetching of
-closures. If fetching is necessary (i.e. current closure is not local) then
-an automatic context switch is done.
-
---------------------------------------------------------------
-A heap/stack check at a function or thunk entry point.
-
-\begin{code}
-funEntryChecks :: ClosureInfo -> CmmStmts -> Maybe [GlobalReg] -> Code -> Code
-funEntryChecks cl_info reg_save_code live code
-  = hpStkCheck cl_info True reg_save_code live code
-
-thunkEntryChecks :: ClosureInfo -> Code -> Code
-thunkEntryChecks cl_info code
-  = hpStkCheck cl_info False noStmts (Just [node]) code
-
-hpStkCheck :: ClosureInfo       -- Function closure
-           -> Bool              -- Is a function? (not a thunk)
-           -> CmmStmts          -- Register saves
-           -> Maybe [GlobalReg] -- Live registers
-           -> Code
-           -> Code
-
-hpStkCheck cl_info is_fun reg_save_code live code
-  =  getFinalStackHW    $ \ spHw -> do
-        { sp <- getRealSp
-        ; let stk_words = spHw - sp
-        ; initHeapUsage $ \ hpHw  -> do
-            {   -- Emit heap checks, but be sure to do it lazily so
-                -- that the conditionals on hpHw don't cause a black hole
-              codeOnly $ do
-
-                dflags <- getDynFlags
-
-                let (node_asst, full_live)
-                        | nodeMustPointToIt dflags (closureLFInfo cl_info)
-                        = (noStmts, live)
-                        | otherwise
-                        = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl)))
-                          ,Just $ node : fromMaybe [] live)
-                        -- Strictly speaking, we should tag node here.  But if
-                        -- node doesn't point to the closure, the code for the closure
-                        -- cannot depend on the value of R1 anyway, so we're safe.
-
-                    full_save_code = node_asst `plusStmts` reg_save_code
-
-                do_checks stk_words hpHw full_save_code rts_label full_live
-                tickyAllocHeap hpHw
-            ; setRealHp hpHw
-            ; code }
-        }
-  where
-    closure_lbl = closureLabelFromCI cl_info
-
-
-    rts_label | is_fun    = CmmReg (CmmGlobal GCFun)
-                                -- Function entry point
-              | otherwise = CmmReg (CmmGlobal GCEnter1)
-                                -- Thunk or case return
-        -- In the thunk/case-return case, R1 points to a closure
-        -- which should be (re)-entered after GC
-\end{code}
-
-Heap checks in a case alternative are nice and easy, provided this is
-a bog-standard algebraic case.  We have in our hand:
-
-       * one return address, on the stack,
-       * one return value, in Node.
-
-the canned code for this heap check failure just pushes Node on the
-stack, saying 'EnterGHC' to return.  The scheduler will return by
-entering the top value on the stack, which in turn will return through
-the return address, getting us back to where we were.  This is
-therefore only valid if the return value is *lifted* (just being
-boxed isn't good enough).
-
-For primitive returns, we have an unlifted value in some register
-(either R1 or FloatReg1 or DblReg1).  This means using specialised
-heap-check code for these cases.
-
-\begin{code}
-altHeapCheck
-    :: AltType  -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
-                --      (Unboxed tuples are dealt with by ubxTupleHeapCheck)
-    -> Code     -- Continuation
-    -> Code
-altHeapCheck alt_type code
-  = initHeapUsage $ \ hpHw -> do
-        { codeOnly $ do
-             { do_checks 0 {- no stack chk -} hpHw
-                         noStmts {- nothign to save -}
-                         rts_label live
-             ; tickyAllocHeap hpHw }
-        ; setRealHp hpHw
-        ; code }
-  where
-    (rts_label, live) = gc_info alt_type
-
-    mkL l = CmmLit . CmmLabel $ mkCmmCodeLabel rtsPackageId (fsLit l)
-
-    gc_info PolyAlt = (mkL "stg_gc_unpt_r1" , Just [node])
-
-        -- Do *not* enter R1 after a heap check in
-        -- a polymorphic case.  It might be a function
-        -- and the entry code for a function (currently)
-        -- applies it
-        --
-        -- However R1 is guaranteed to be a pointer
-
-    gc_info (AlgAlt _) = (stg_gc_enter1, Just [node])
-        -- Enter R1 after the heap check; it's a pointer
-
-    gc_info (PrimAlt tc)
-      = case primRepToCgRep (tyConPrimRep tc) of
-          VoidArg   -> (mkL "stg_gc_noregs", Just [])
-          FloatArg  -> (mkL "stg_gc_f1", Just [FloatReg 1])
-          DoubleArg -> (mkL "stg_gc_d1", Just [DoubleReg 1])
-          LongArg   -> (mkL "stg_gc_l1", Just [LongReg 1])
-                                -- R1 is boxed but unlifted:
-          PtrArg    -> (mkL "stg_gc_unpt_r1", Just [node])
-                                -- R1 is unboxed:
-          NonPtrArg -> (mkL "stg_gc_unbx_r1", Just [node])
-
-    gc_info (UbxTupAlt _) = panic "altHeapCheck"
-\end{code}
-
-
-Unboxed tuple alternatives and let-no-escapes (the two most annoying
-constructs to generate code for!)  For unboxed tuple returns, there
-are an arbitrary number of possibly unboxed return values, some of
-which will be in registers, and the others will be on the stack.  We
-always organise the stack-resident fields into pointers &
-non-pointers, and pass the number of each to the heap check code.
-
-\begin{code}
-unbxTupleHeapCheck
-        :: [(Id, GlobalReg)]    -- Live registers
-        -> WordOff              -- no. of stack slots containing ptrs
-        -> WordOff              -- no. of stack slots containing nonptrs
-        -> CmmStmts             -- code to insert in the failure path
-        -> Code
-        -> Code
-
-unbxTupleHeapCheck regs ptrs nptrs fail_code code
-  -- We can't manage more than 255 pointers/non-pointers
-  -- in a generic heap check.
-  | ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
-  | otherwise
-  = initHeapUsage $ \ hpHw -> do
-        { dflags <- getDynFlags
-        ; let full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
-              assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr))    -- Ho ho ho!
-                                          (CmmLit (mkStgWordCLit dflags liveness))
-              liveness        = mkRegLiveness dflags regs ptrs nptrs
-              live            = Just $ map snd regs
-              rts_label       = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
-        ; codeOnly $ do { do_checks 0 {- no stack check -} hpHw
-                                    full_fail_code rts_label live
-                        ; tickyAllocHeap hpHw }
-        ; setRealHp hpHw
-        ; code }
-
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-                Heap/Stack Checks.
-%*                                                                      *
-%************************************************************************
-
-When failing a check, we save a return address on the stack and
-jump to a pre-compiled code fragment that saves the live registers
-and returns to the scheduler.
-
-The return address in most cases will be the beginning of the basic
-block in which the check resides, since we need to perform the check
-again on re-entry because someone else might have stolen the resource
-in the meantime.
-
-\begin{code}
-do_checks :: WordOff           -- Stack headroom
-          -> WordOff           -- Heap  headroom
-          -> CmmStmts          -- Assignments to perform on failure
-          -> CmmExpr           -- Rts address to jump to on failure
-          -> Maybe [GlobalReg] -- Live registers
-          -> Code
-do_checks 0 0 _ _ _ = nopC
-
-do_checks stk hp reg_save_code rts_lbl live
-  = do dflags <- getDynFlags
-       if hp > bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags
-           then sorry (unlines [
-                    "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE dflags) ++ " bytes.",
-                    "",
-                    "See: http://hackage.haskell.org/trac/ghc/ticket/4505",
-                    "Suggestion: read data from a file instead of having large static data",
-                    "structures in the code."])
-           else do_checks' (mkIntExpr dflags (stk * wORD_SIZE dflags))
-                           (mkIntExpr dflags (hp * wORD_SIZE dflags))
-                    (stk /= 0) (hp /= 0) reg_save_code rts_lbl live
-
--- The offsets are now in *bytes*
-do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr
-           -> Maybe [GlobalReg] -> Code
-do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live
-  = do  { dflags <- getDynFlags
-
-        -- Stk overflow if (Sp - stk_bytes < SpLim)
-        ; let stk_oflo = CmmMachOp (mo_wordULt dflags)
-                             [CmmMachOp (mo_wordSub dflags) [CmmReg spReg, stk_expr],
-                              CmmReg (CmmGlobal SpLim)]
-
-        -- Hp overflow if (Hp > HpLim)
-        -- (Hp has been incremented by now)
-        -- HpLim points to the LAST WORD of valid allocation space.
-              hp_oflo = CmmMachOp (mo_wordUGt dflags)
-                            [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
-  
-        ; doGranAllocate hp_expr
-
-        -- The failure block: this saves the registers and jumps to
-        -- the appropriate RTS stub.
-        ; exit_blk_id <- forkLabelledCode $ do {
-                        ; emitStmts reg_save_code
-                        ; stmtC (CmmJump rts_lbl live) }
-
-        -- In the case of a heap-check failure, we must also set
-        -- HpAlloc.  NB. HpAlloc is *only* set if Hp has been
-        -- incremented by the heap check, it must not be set in the
-        -- event that a stack check failed, because the RTS stub will
-        -- retreat Hp by HpAlloc.
-        ; hp_blk_id <- if hp_nonzero
-                          then forkLabelledCode $ do
-                                  stmtC (CmmAssign (CmmGlobal HpAlloc) hp_expr)
-                                  stmtC (CmmBranch exit_blk_id)
-                          else return exit_blk_id
-
-        -- Check for stack overflow *FIRST*; otherwise
-        -- we might bumping Hp and then failing stack oflo
-        ; whenC stk_nonzero
-                (stmtC (CmmCondBranch stk_oflo exit_blk_id))
-
-        ; whenC hp_nonzero
-                (stmtsC [CmmAssign hpReg
-                                (cmmOffsetExprB dflags (CmmReg hpReg) hp_expr),
-                        CmmCondBranch hp_oflo hp_blk_id])
-                -- Bump heap pointer, and test for heap exhaustion
-                -- Note that we don't move the heap pointer unless the
-                -- stack check succeeds.  Otherwise we might end up
-                -- with slop at the end of the current block, which can
-                -- confuse the LDV profiler.
-    }
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-     Generic Heap/Stack Checks - used in the RTS
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
-hpChkGen bytes liveness reentry
-  = do dflags <- getDynFlags
-       let platform = targetPlatform dflags
-           assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness,
-                               mk_vanilla_assignment dflags 10 reentry ]
-       do_checks' (zeroExpr dflags) bytes False True assigns
-                  stg_gc_gen (Just (activeStgRegs platform))
-
--- a heap check where R1 points to the closure to enter on return, and
--- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
-hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code
-hpChkNodePointsAssignSp0 bytes sp0
-  = do dflags <- getDynFlags
-       do_checks' (zeroExpr dflags) bytes False True assign
-           stg_gc_enter1 (Just [node])
-  where assign = oneStmt (CmmStore (CmmReg spReg) sp0)
-
-stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code
-stkChkGen bytes liveness reentry
-  = do dflags <- getDynFlags
-       let platform = targetPlatform dflags
-           assigns = mkStmts [ mk_vanilla_assignment dflags 9 liveness,
-                               mk_vanilla_assignment dflags 10 reentry ]
-       do_checks' bytes (zeroExpr dflags) True False assigns
-                  stg_gc_gen (Just (activeStgRegs platform))
-
-mk_vanilla_assignment :: DynFlags -> Int -> CmmExpr -> CmmStmt
-mk_vanilla_assignment dflags n e
-  = CmmAssign (CmmGlobal (VanillaReg n (vgcFlag (cmmExprType dflags e)))) e
-
-stkChkNodePoints :: CmmExpr -> Code
-stkChkNodePoints bytes
-  = do dflags <- getDynFlags
-       do_checks' bytes (zeroExpr dflags) True False noStmts
-           stg_gc_enter1 (Just [node])
-
-stg_gc_gen :: CmmExpr
-stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen")))
-stg_gc_enter1 :: CmmExpr
-stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[initClosure]{Initialise a dynamic closure}
-%*                                                                      *
-%************************************************************************
-
-@allocDynClosure@ puts the thing in the heap, and modifies the virtual Hp
-to account for this.
-
-\begin{code}
-allocDynClosure
-        :: ClosureInfo
-        -> CmmExpr              -- Cost Centre to stick in the object
-        -> CmmExpr              -- Cost Centre to blame for this alloc
-                                -- (usually the same; sometimes "OVERHEAD")
-
-        -> [(CmmExpr, VirtualHpOffset)] -- Offsets from start of the object
-                                        -- ie Info ptr has offset zero.
-        -> FCode VirtualHpOffset        -- Returns virt offset of object
-
-allocDynClosure cl_info use_cc _blame_cc amodes_with_offsets
-  = do  { virt_hp <- getVirtHp
-
-        -- FIND THE OFFSET OF THE INFO-PTR WORD
-        ; dflags <- getDynFlags
-        ; let   info_offset = virt_hp + 1
-                -- info_offset is the VirtualHpOffset of the first
-                -- word of the new object
-                -- Remember, virtHp points to last allocated word,
-                -- ie 1 *before* the info-ptr word of new object.
-
-                info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
-                hdr_w_offsets = initDynHdr dflags info_ptr use_cc `zip` [0..]
-
-        -- SAY WHAT WE ARE ABOUT TO DO
-        ; profDynAlloc cl_info use_cc
-        ; tickyDynAlloc cl_info
-
-        -- ALLOCATE THE OBJECT
-        ; base <- getHpRelOffset info_offset
-        ; hpStore base (hdr_w_offsets ++ amodes_with_offsets)
-
-        -- BUMP THE VIRTUAL HEAP POINTER
-        ; setVirtHp (virt_hp + closureSize dflags cl_info)
-
-        -- RETURN PTR TO START OF OBJECT
-        ; returnFC info_offset }
-
-
-initDynHdr :: DynFlags
-           -> CmmExpr
-           -> CmmExpr           -- Cost centre to put in object
-           -> [CmmExpr]
-initDynHdr dflags info_ptr cc
-  =  [info_ptr]
-        -- ToDo: Gransim stuff
-        -- ToDo: Parallel stuff
-  ++ dynProfHdr dflags cc
-        -- No ticky header
-
-hpStore :: CmmExpr -> [(CmmExpr, VirtualHpOffset)] -> Code
--- Store the item (expr,off) in base[off]
-hpStore base es
-  = do dflags <- getDynFlags
-       stmtsC [ CmmStore (cmmOffsetW dflags base off) val
-              | (val, off) <- es ]
-
-emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> Code
-emitSetDynHdr base info_ptr ccs
-  = do dflags <- getDynFlags
-       hpStore base (zip (initDynHdr dflags info_ptr ccs) [0..])
-\end{code}
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
deleted file mode 100644 (file)
index 407de7b..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
------------------------------------------------------------------------------
---
--- Code generation for coverage
---
--- (c) Galois Connections, Inc. 2006
---
------------------------------------------------------------------------------
-
-module CgHpc (cgTickBox, hpcTable) where
-
-import OldCmm
-import CLabel
-import Module
-import OldCmmUtils
-import CgUtils
-import CgMonad
-import HscTypes
-
-cgTickBox :: Module -> Int -> Code
-cgTickBox mod n = do
-       dflags <- getDynFlags
-       let tick_box = (cmmIndex dflags W64
-                       (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
-                       n
-                      )
-       stmtsC [ CmmStore tick_box
-                         (CmmMachOp (MO_Add W64)
-                                               [ CmmLoad tick_box b64
-                                               , CmmLit (CmmInt 1 W64)
-                                               ])
-              ] 
-
-hpcTable :: Module -> HpcInfo -> Code
-hpcTable this_mod (HpcInfo hpc_tickCount _) = do
-                        emitDataLits (mkHpcTicksLabel this_mod) $
-                                        [ CmmInt 0 W64
-                                        | _ <- take hpc_tickCount [0::Int ..]
-                                        ]
-
-hpcTable _ (NoHpcInfo {}) = error "TODO: impossible"
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
deleted file mode 100644 (file)
index be16bf6..0000000
+++ /dev/null
@@ -1,374 +0,0 @@
------------------------------------------------------------------------------
---
--- Building info tables.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgInfoTbls (
-       emitClosureCodeAndInfoTable,
-       emitInfoTableAndCode,
-       emitReturnTarget, emitAlgReturnTarget,
-       emitReturnInstr,
-       stdInfoTableSizeB,
-       entryCode, closureInfoPtr,
-       getConstrTag,
-        cmmGetClosureType,
-       infoTable, infoTableClosureType,
-       infoTablePtrs, infoTableNonPtrs,
-       funInfoTable
-  ) where
-
-
-#include "HsVersions.h"
-
-import ClosureInfo
-import SMRep
-import CgBindery
-import CgCallConv
-import CgUtils
-import CgMonad
-import CmmUtils
-
-import OldCmm
-import CLabel
-import Name
-import Unique
-
-import DynFlags
-import Util
-import Outputable
-
--------------------------------------------------------------------------
---
---     Generating the info table and code for a closure
---
--------------------------------------------------------------------------
-
--- Here we make an info table of type 'CmmInfo'.  The concrete
--- representation as a list of 'CmmAddr' is handled later
--- in the pipeline by 'cmmToRawCmm'.
-
-emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code
-emitClosureCodeAndInfoTable cl_info args body
- = do   { dflags <- getDynFlags
-        ; blks <- cgStmtsToBlocks body
-        ; info <- mkCmmInfo cl_info
-        ; emitInfoTableAndCode (entryLabelFromCI dflags cl_info) info args blks }
-
--- Convert from 'ClosureInfo' to 'CmmInfo'.
--- Not used for return points.  (The 'smRepClosureTypeInt' call would panic.)
-mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable
-mkCmmInfo cl_info
-  = do dflags <- getDynFlags
-       return (CmmInfoTable { cit_lbl  = infoTableLabelFromCI cl_info,
-                              cit_rep  = closureSMRep cl_info,
-                              cit_prof = prof dflags,
-                              cit_srt  = closureSRT cl_info })
-  where
-    prof dflags | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
-                | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
-    ty_descr_w8  = stringToWord8s (closureTypeDescr cl_info)
-    val_descr_w8 = stringToWord8s (closureValDescr cl_info)
-
--------------------------------------------------------------------------
---
---     Generating the info table and code for a return point
---
--------------------------------------------------------------------------
-
--- The concrete representation as a list of 'CmmAddr' is handled later
--- in the pipeline by 'cmmToRawCmm'.
-
-emitReturnTarget
-   :: Name
-   -> CgStmts                  -- The direct-return code (if any)
-   -> FCode CLabel
-emitReturnTarget name stmts
-  = do dflags <- getDynFlags
-       srt_info   <- getSRTInfo
-       blks <- cgStmtsToBlocks stmts
-       frame <- mkStackLayout
-       let smrep    = mkStackRep (mkLiveness dflags frame)
-           info     = CmmInfoTable { cit_lbl  = info_lbl
-                                   , cit_prof = NoProfilingInfo
-                                   , cit_rep  = smrep
-                                   , cit_srt  = srt_info }
-       emitInfoTableAndCode entry_lbl info args blks
-       return info_lbl
-  where
-    args      = {- trace "emitReturnTarget: missing args" -} []
-    uniq      = getUnique name
-    info_lbl  = mkReturnInfoLabel uniq
-    entry_lbl = mkReturnPtLabel uniq
-
--- Build stack layout information from the state of the 'FCode' monad.
--- Should go away once 'codeGen' starts using the CPS conversion
--- pass to handle the stack.  Until then, this is really just
--- here to convert from the 'codeGen' representation of the stack
--- to the 'CmmInfo' representation of the stack.
---
--- See 'CmmInfo.mkLiveness' for where this is converted to a bitmap.
-
-{-
-This seems to be a very error prone part of the code.
-It is surprisingly prone to off-by-one errors, because
-it converts between offset form (codeGen) and list form (CmmInfo).
-Thus a bit of explanation is in order.
-Fortunately, this code should go away once the code generator
-starts using the CPS conversion pass to handle the stack.
-
-The stack looks like this:
-
-             |             |
-             |-------------|
-frame_sp --> | return addr |
-             |-------------|
-             | dead slot   |
-             |-------------|
-             | live ptr b  |
-             |-------------|
-             | live ptr a  |
-             |-------------|
-real_sp  --> | return addr |
-             +-------------+
-
-Both 'frame_sp' and 'real_sp' are measured downwards
-(i.e. larger frame_sp means smaller memory address).
-
-For that frame we want a result like: [Just a, Just b, Nothing]
-Note that the 'head' of the list is the top
-of the stack, and that the return address
-is not present in the list (it is always assumed).
--}
-mkStackLayout :: FCode [Maybe LocalReg]
-mkStackLayout = do
-  dflags <- getDynFlags
-  StackUsage { realSp = real_sp,
-               frameSp = frame_sp } <- getStkUsage
-  binds <- getLiveStackBindings
-  let frame_size = real_sp - frame_sp - retAddrSizeW
-      rel_binds = reverse $ sortWith fst
-                    [(offset - frame_sp - retAddrSizeW, b)
-                    | (offset, b) <- binds]
-
-  WARN( not (all (\bind -> fst bind >= 0) rel_binds),
-        ppr binds $$ ppr rel_binds $$
-        ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
-    return $ stack_layout dflags rel_binds frame_size
-
-stack_layout :: DynFlags
-             -> [(VirtualSpOffset, CgIdInfo)]
-             -> WordOff
-             -> [Maybe LocalReg]
-stack_layout _ [] sizeW = replicate sizeW Nothing
-stack_layout dflags ((off, bind):binds) sizeW | off == sizeW - 1 =
-  (Just stack_bind) : (stack_layout dflags binds (sizeW - rep_size))
-  where
-    rep_size = cgRepSizeW dflags (cgIdInfoArgRep bind)
-    stack_bind = LocalReg unique machRep
-    unique = getUnique (cgIdInfoId bind)
-    machRep = argMachRep dflags (cgIdInfoArgRep bind)
-stack_layout dflags binds@(_:_) sizeW | otherwise =
-  Nothing : (stack_layout dflags binds (sizeW - 1))
-
-{- Another way to write the function that might be less error prone (untested)
-stack_layout offsets sizeW = result
-  where
-    y = map (flip lookup offsets) [0..]
-      -- offsets -> nothing and just (each slot is one word)
-    x = take sizeW y -- set the frame size
-    z = clip x -- account for multi-word slots
-    result = map mk_reg z
-
-    clip [] = []
-    clip list@(x : _) = x : clip (drop count list)
-      ASSERT(all isNothing (tail (take count list)))
-    
-    count Nothing = 1
-    count (Just x) = cgRepSizeW (cgIdInfoArgRep x)
-
-    mk_reg Nothing = Nothing
-    mk_reg (Just x) = LocalReg unique machRep kind
-      where
-        unique = getUnique (cgIdInfoId x)
-        machRep = argMachrep (cgIdInfoArgRep bind)
-        kind = if isFollowableArg (cgIdInfoArgRep bind)
-           then GCKindPtr
-           else GCKindNonPtr
--}
-
-emitAlgReturnTarget
-       :: Name                         -- Just for its unique
-       -> [(ConTagZ, CgStmts)]         -- Tagged branches
-       -> Maybe CgStmts                -- Default branch (if any)
-       -> Int                          -- family size
-       -> FCode (CLabel, SemiTaggingStuff)
-
-emitAlgReturnTarget name branches mb_deflt fam_sz
-  = do  { blks <- getCgStmts $ do
-                    -- is the constructor tag in the node reg?
-                    dflags <- getDynFlags
-                    if isSmallFamily dflags fam_sz
-                        then do -- yes, node has constr. tag
-                          let tag_expr = cmmConstrTag1 dflags (CmmReg nodeReg)
-                              branches' = [(tag+1,branch)|(tag,branch)<-branches]
-                          emitSwitch tag_expr branches' mb_deflt 1 fam_sz
-                        else do -- no, get tag from info table
-                          let -- Note that ptr _always_ has tag 1
-                              -- when the family size is big enough
-                              untagged_ptr = cmmRegOffB nodeReg (-1)
-                              tag_expr = getConstrTag dflags untagged_ptr
-                          emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
-       ; lbl <- emitReturnTarget name blks
-       ; return (lbl, Nothing) }
-               -- Nothing: the internal branches in the switch don't have
-               -- global labels, so we can't use them at the 'call site'
-
---------------------------------
-emitReturnInstr :: Maybe [GlobalReg] -> Code
-emitReturnInstr live
-  = do { dflags <- getDynFlags
-       ; info_amode <- getSequelAmode
-       ; stmtC (CmmJump (entryCode dflags info_amode) live) }
-
------------------------------------------------------------------------------
---
---     Info table offsets
---
------------------------------------------------------------------------------
-       
-stdInfoTableSizeW :: DynFlags -> WordOff
--- The size of a standard info table varies with profiling/ticky etc,
--- so we can't get it from Constants
--- It must vary in sync with mkStdInfoTable
-stdInfoTableSizeW dflags
-  = size_fixed + size_prof
-  where
-    size_fixed = 2     -- layout, type
-    size_prof | gopt Opt_SccProfilingOn dflags = 2
-              | otherwise                      = 0
-
-stdInfoTableSizeB :: DynFlags -> ByteOff
-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
-
-stdSrtBitmapOffset :: DynFlags -> ByteOff
--- Byte offset of the SRT bitmap half-word which is 
--- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
-
-stdClosureTypeOffset :: DynFlags -> ByteOff
--- Byte offset of the closure type half-word 
-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
-
-stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
-stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
-
--------------------------------------------------------------------------
---
---     Accessing fields of an info table
---
--------------------------------------------------------------------------
-
-closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer and returns the info table pointer
-closureInfoPtr dflags e = CmmLoad e (bWord dflags)
-
-entryCode :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info pointer (the first word of a closure)
--- and returns its entry code
-entryCode dflags e
- | tablesNextToCode dflags = e
- | otherwise               = CmmLoad e (bWord dflags)
-
-getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer, and return the *zero-indexed*
--- constructor tag obtained from the info table
--- This lives in the SRT field of the info table
--- (constructors don't need SRTs).
-getConstrTag dflags closure_ptr
-  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
-  where
-    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
-
-cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer, and return the closure type
--- obtained from the info table
-cmmGetClosureType dflags closure_ptr
-  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
-  where
-    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
-
-infoTable :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info pointer (the first word of a closure)
--- and returns a pointer to the first word of the standard-form
--- info table, excluding the entry-code word (if present)
-infoTable dflags info_ptr
-  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
-  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
-
-infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the constr tag
--- field of the info table (same as the srt_bitmap field)
-infoTableConstrTag = infoTableSrtBitmap
-
-infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the srt_bitmap
--- field of the info table
-infoTableSrtBitmap dflags info_tbl
-  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
-
-infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the closure type
--- field of the info table.
-infoTableClosureType dflags info_tbl
-  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
-
-infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
-infoTablePtrs dflags info_tbl
-  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
-
-infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
-infoTableNonPtrs dflags info_tbl
-  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
-
-funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
--- Takes the info pointer of a function,
--- and returns a pointer to the first word of the StgFunInfoExtra struct
--- in the info table.
-funInfoTable dflags info_ptr
-  | tablesNextToCode dflags
-  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
-  | otherwise
-  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
-                               -- Past the entry code pointer
-
--------------------------------------------------------------------------
---
---     Emit the code for a closure (or return address)
---     and its associated info table
---
--------------------------------------------------------------------------
-
--- The complication here concerns whether or not we can
--- put the info table next to the code
-
-emitInfoTableAndCode 
-       :: CLabel               -- Label of entry or ret
-        -> CmmInfoTable         -- ...the info table
-        -> [CmmFormal]          -- ...args
-       -> [CmmBasicBlock]      -- ...and body
-       -> Code
-
-emitInfoTableAndCode entry_ret_lbl info args blocks
-  = emitProc (Just info) entry_ret_lbl args blocks
-
diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs
deleted file mode 100644 (file)
index 610869a..0000000
+++ /dev/null
@@ -1,215 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-%
-%********************************************************
-%*                                                     *
-\section[CgLetNoEscape]{Handling ``let-no-escapes''}
-%*                                                     *
-%********************************************************
-
-\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgLetNoEscape ( cgLetNoEscapeClosure ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} CgExpr ( cgExpr )
-
-import StgSyn
-import CgMonad
-
-import CgBindery
-import CgCase
-import CgCon
-import CgHeapery
-import CgInfoTbls
-import CgStackery
-import OldCmm
-import OldCmmUtils
-import CLabel
-import ClosureInfo
-import CostCentre
-import Id
-import BasicTypes
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection[what-is-non-escaping]{What {\em is} a ``non-escaping let''?}
-%*                                                                     *
-%************************************************************************
-
-[The {\em code} that detects these things is elsewhere.]
-
-Consider:
-\begin{verbatim}
-       let x = fvs \ args -> e
-       in
-               if ... then x else
-               if ... then x else ...
-\end{verbatim}
-@x@ is used twice (so we probably can't unfold it), but when it is
-entered, the stack is deeper than it was when the definition of @x@
-happened.  Specifically, if instead of allocating a closure for @x@,
-we saved all @x@'s fvs on the stack, and remembered the stack depth at
-that moment, then whenever we enter @x@ we can simply set the stack
-pointer(s) to these remembered (compile-time-fixed) values, and jump
-to the code for @x@.
-
-All of this is provided x is:
-\begin{enumerate}
-\item
-non-updatable;
-\item
-guaranteed to be entered before the stack retreats -- ie x is not
-buried in a heap-allocated closure, or passed as an argument to something;
-\item
-all the enters have exactly the right number of arguments,
-no more no less;
-\item
-all the enters are tail calls; that is, they return to the
-caller enclosing the definition of @x@.
-\end{enumerate}
-
-Under these circumstances we say that @x@ is {\em non-escaping}.
-
-An example of when (4) does {\em not} hold:
-\begin{verbatim}
-       let x = ...
-       in case x of ...alts...
-\end{verbatim}
-
-Here, @x@ is certainly entered only when the stack is deeper than when
-@x@ is defined, but here it must return to \tr{...alts...} So we can't
-just adjust the stack down to @x@'s recalled points, because that
-would lost @alts@' context.
-
-Things can get a little more complicated.  Consider:
-\begin{verbatim}
-       let y = ...
-       in let x = fvs \ args -> ...y...
-       in ...x...
-\end{verbatim}
-
-Now, if @x@ is used in a non-escaping way in \tr{...x...}, {\em and}
-@y@ is used in a non-escaping way in \tr{...y...}, {\em then} @y@ is
-non-escaping.
-
-@x@ can even be recursive!  Eg:
-\begin{verbatim}
-       letrec x = [y] \ [v] -> if v then x True else ...
-       in
-               ...(x b)...
-\end{verbatim}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection[codeGen-for-non-escaping]{Generating code for a ``non-escaping let''}
-%*                                                                     *
-%************************************************************************
-
-
-Generating code for this is fun.  It is all very very similar to what
-we do for a case expression.  The duality is between
-\begin{verbatim}
-       let-no-escape x = b
-       in e
-\end{verbatim}
-and
-\begin{verbatim}
-       case e of ... -> b
-\end{verbatim}
-
-That is, the RHS of @x@ (ie @b@) will execute {\em later}, just like
-the alternative of the case; it needs to be compiled in an environment
-in which all volatile bindings are forgotten, and the free vars are
-bound only to stable things like stack locations..  The @e@ part will
-execute {\em next}, just like the scrutinee of a case.
-
-First, we need to save all @x@'s free vars
-on the stack, if they aren't there already.
-
-\begin{code}
-cgLetNoEscapeClosure
-       :: Id                   -- binder
-       -> CostCentreStack      -- NB: *** NOT USED *** ToDo (WDP 94/06)
-       -> StgBinderInfo        -- NB: ditto
-       -> StgLiveVars          -- variables live in RHS, including the binders
-                               -- themselves in the case of a recursive group
-       -> EndOfBlockInfo       -- where are we going to?
-       -> Maybe VirtualSpOffset -- Slot for current cost centre
-       -> RecFlag              -- is the binding recursive?
-       -> [Id]                 -- args (as in \ args -> body)
-       -> StgExpr              -- body (as in above)
-       -> FCode (Id, CgIdInfo)
-
--- ToDo: deal with the cost-centre issues
-
-cgLetNoEscapeClosure 
-       bndr cc _ full_live_in_rhss 
-       rhs_eob_info cc_slot _ args body
-  = let
-       arity   = length args
-       lf_info = mkLFLetNoEscape arity
-    in
-    -- saveVolatileVarsAndRegs done earlier in cgExpr.
-
-    do  { dflags <- getDynFlags
-        ; (vSp, _) <- forkEvalHelp rhs_eob_info
-
-               (do { allocStackTop retAddrSizeW
-                   ; nukeDeadBindings full_live_in_rhss })
-
-               (do { deAllocStackTop retAddrSizeW
-                   ; abs_c <- forkProc $ cgLetNoEscapeBody bndr cc 
-                                                 cc_slot args body
-
-                       -- Ignore the label that comes back from
-                       -- mkRetDirectTarget.  It must be conjured up elswhere
-                   ; _ <- emitReturnTarget (idName bndr) abs_c
-                   ; return () })
-
-       ; returnFC (bndr, letNoEscapeIdInfo dflags bndr vSp lf_info) }
-\end{code}
-
-\begin{code}
-cgLetNoEscapeBody :: Id                -- Name of the joint point
-                 -> CostCentreStack
-                 -> Maybe VirtualSpOffset
-                 -> [Id]       -- Args
-                 -> StgExpr    -- Body
-                 -> Code
-
-cgLetNoEscapeBody bndr _ cc_slot all_args body = do
-  { (arg_regs, ptrs, nptrs, ret_slot) <- bindUnboxedTupleComponents all_args
-
-     -- restore the saved cost centre.  BUT: we must not free the stack slot
-     -- containing the cost centre, because it might be needed for a
-     -- recursive call to this let-no-escape.
-  ; restoreCurrentCostCentre cc_slot False{-don't free-}
-
-       -- Enter the closures cc, if required
-  ; -- enterCostCentreCode closure_info cc IsFunction
-
-       -- The "return address" slot doesn't have a return address in it;
-       -- but the heap-check needs it filled in if the heap-check fails.
-       -- So we pass code to fill it in to the heap-check macro
-  ; sp_rel <- getSpRelOffset ret_slot
-
-  ; let        lbl            = mkReturnInfoLabel (idUnique bndr)
-       frame_hdr_asst = oneStmt (CmmStore sp_rel (mkLblExpr lbl))
-
-       -- Do heap check [ToDo: omit for non-recursive case by recording in
-       --      in envt and absorbing at call site]
-  ; unbxTupleHeapCheck arg_regs ptrs nptrs frame_hdr_asst 
-                       (cgExpr body)
-  }
-\end{code}
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
deleted file mode 100644 (file)
index f776af3..0000000
+++ /dev/null
@@ -1,849 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgMonad]{The code generation monad}
-
-See the beginning of the top-level @CodeGen@ module, to see how this monadic
-stuff fits into the Big Picture.
-
-\begin{code}
-
-{-# LANGUAGE BangPatterns #-}
-module CgMonad (
-        Code, FCode,
-
-        initC, runC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
-        returnFC, fixC, fixC_, checkedAbsC, 
-        stmtC, stmtsC, labelC, emitStmts, nopC, whenC, newLabelC,
-        newUnique, newUniqSupply,
-
-        CgStmts, emitCgStmts, forkCgStmts, cgStmtsToBlocks,
-        getCgStmts', getCgStmts,
-        noCgStmts, oneCgStmt, consCgStmt,
-
-        getCmm,
-        emitDecl, emitProc, emitSimpleProc,
-
-        forkLabelledCode,
-        forkClosureBody, forkStatics, forkAlts, forkEval,
-        forkEvalHelp, forkProc, codeOnly,
-        SemiTaggingStuff, ConTagZ,
-
-        EndOfBlockInfo(..),
-        setEndOfBlockInfo, getEndOfBlockInfo,
-
-        setSRT, getSRT,
-        setSRTLabel, getSRTLabel,
-        setTickyCtrLabel, getTickyCtrLabel,
-
-        StackUsage(..), HeapUsage(..),
-        VirtualSpOffset, VirtualHpOffset,
-        initStkUsage, initHpUsage,
-        getHpUsage,  setHpUsage,
-        heapHWM,
-
-        getModuleName,
-
-        Sequel(..),
-
-        -- ideally we wouldn't export these, but some other modules access
-        -- internal state
-        getState, setState, getInfoDown, getDynFlags, getThisPackage,
-
-        -- more localised access to monad state
-        getStkUsage, setStkUsage,
-        getBinds, setBinds, getStaticBinds,
-
-        -- out of general friendliness, we also export ...
-        CgInfoDownwards(..), CgState(..)
-    ) where
-
-#include "HsVersions.h"
-
-import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
-
-import DynFlags
-import BlockId
-import OldCmm
-import OldCmmUtils
-import CLabel
-import StgSyn (SRT)
-import ClosureInfo( ConTagZ )
-import SMRep
-import Module
-import Id
-import VarEnv
-import OrdList
-import Unique
-import UniqSupply
-import Util
-import Outputable
-
-import Control.Monad
-import Data.List
-
-infixr 9 `thenC`
-infixr 9 `thenFC`
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-\subsection[CgMonad-environment]{Stuff for manipulating environments}
-%*                                                                      *
-%************************************************************************
-
-This monadery has some information that it only passes {\em downwards}, as well
-as some ``state'' which is modified as we go along.
-
-\begin{code}
-
--- | State only passed *downwards* by the monad
-data CgInfoDownwards
-  = MkCgInfoDown {
-        cgd_dflags  :: DynFlags,      -- current flag settings
-        cgd_mod     :: Module,        -- Module being compiled
-        cgd_statics :: CgBindings,    -- [Id -> info] : static environment
-        cgd_srt_lbl :: CLabel,        -- label of the current SRT
-        cgd_srt     :: SRT,           -- the current SRT
-        cgd_ticky   :: CLabel,        -- current destination for ticky counts
-        cgd_eob     :: EndOfBlockInfo -- Info for stuff to do at end of basic block:
-  }
-
--- | Setup initial @CgInfoDownwards@ for the code gen
-initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
-initCgInfoDown dflags mod
-  = MkCgInfoDown { cgd_dflags  = dflags,
-                   cgd_mod     = mod,
-                   cgd_statics = emptyVarEnv,
-                   cgd_srt_lbl = error "initC: srt_lbl",
-                   cgd_srt     = error "initC: srt",
-                   cgd_ticky   = mkTopTickyCtrLabel,
-                   cgd_eob     = initEobInfo
-  }
-
--- | State passed around and modified during code generation
-data CgState
-  = MkCgState {
-     cgs_stmts   :: OrdList CgStmt,
-         -- Current proc
-     cgs_tops    :: OrdList CmmDecl,
-         -- Other procedures and data blocks in this compilation unit
-         -- Both the latter two are ordered only so that we can
-         -- reduce forward references, when it's easy to do so
-
-     cgs_binds   :: CgBindings,
-         -- [Id -> info] : *local* bindings environment Bindings for
-         -- top-level things are given in the info-down part
-
-     cgs_stk_usg :: StackUsage,
-     cgs_hp_usg  :: HeapUsage,
-     cgs_uniqs   :: UniqSupply
-  }
-
--- | Setup initial @CgState@ for the code gen
-initCgState :: UniqSupply -> CgState
-initCgState uniqs
-  = MkCgState { cgs_stmts   = nilOL,
-                cgs_tops    = nilOL,
-                cgs_binds   = emptyVarEnv,
-                cgs_stk_usg = initStkUsage,
-                cgs_hp_usg  = initHpUsage,
-                cgs_uniqs   = uniqs
-  }
-
--- | @EndOfBlockInfo@ tells what to do at the end of this block of code or, if
--- the expression is a @case@, what to do at the end of each alternative.
-data EndOfBlockInfo
-  = EndOfBlockInfo
-        VirtualSpOffset -- Args Sp: trim the stack to this point at a
-                        -- return; push arguments starting just
-                        -- above this point on a tail call.
-                        --
-                        -- This is therefore the stk ptr as seen
-                        -- by a case alternative.
-        Sequel
-
--- | Standard @EndOfBlockInfo@ where the continuation is on the stack
-initEobInfo :: EndOfBlockInfo
-initEobInfo = EndOfBlockInfo 0 OnStack
-
--- | @Sequel@ is a representation of the next continuation to jump to
--- after the current function.
---
--- Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
--- that it must survive stack pointer adjustments at the end of the block.
-data Sequel
-  = OnStack          -- Continuation is on the stack
-
-  | CaseAlts
-          CLabel     -- Jump to this; if the continuation is for a vectored
-                     -- case this might be the label of a return vector
-          SemiTaggingStuff
-          Id          -- The case binder, only used to see if it's dead
-
-type SemiTaggingStuff
-  = Maybe                  -- Maybe we don't have any semi-tagging stuff...
-     ([(ConTagZ, CmmLit)], -- Alternatives
-      CmmLit)              -- Default (will be a can't happen RTS label if can't happen)
-
--- The case branch is executed only from a successful semitagging
--- venture, when a case has looked at a variable, found that it's
--- evaluated, and wants to load up the contents and go to the join
--- point.
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-                CgStmt type
-%*                                                                      *
-%************************************************************************
-
-The CgStmts type is what the code generator outputs: it is a tree of
-statements, including in-line labels. The job of flattenCgStmts is to turn
-this into a list of basic blocks, each of which ends in a jump statement
-(either a local branch or a non-local jump).
-
-\begin{code}
-type CgStmts = OrdList CgStmt
-
-data CgStmt
-  = CgStmt  CmmStmt
-  | CgLabel BlockId
-  | CgFork  BlockId CgStmts
-
-flattenCgStmts :: BlockId -> CgStmts -> [CmmBasicBlock]
-flattenCgStmts id stmts =
-        case flatten (fromOL stmts) of
-          ([],blocks)    -> blocks
-          (block,blocks) -> BasicBlock id block : blocks
- where
-  flatten [] = ([],[])
-
-  -- A label at the end of a function or fork: this label must not be reachable,
-  -- but it might be referred to from another BB that also isn't reachable.
-  -- Eliminating these has to be done with a dead-code analysis.  For now,
-  -- we just make it into a well-formed block by adding a recursive jump.
-  flatten [CgLabel id]
-    = ( [CmmBranch id], [BasicBlock id [CmmBranch id]] )
-
-  -- A jump/branch: throw away all the code up to the next label, because
-  -- it is unreachable.  Be careful to keep forks that we find on the way.
-  flatten (CgStmt stmt : stmts)
-    | isJump stmt
-    = case dropWhile isOrdinaryStmt stmts of
-        []                     -> ( [stmt], [] )
-        [CgLabel id]           -> ( [stmt], [BasicBlock id [CmmBranch id]])
-        (CgLabel id : stmts)   -> ( [stmt], BasicBlock id block : blocks )
-            where (block,blocks) = flatten stmts
-        (CgFork fork_id stmts : ss) ->
-           flatten (CgFork fork_id stmts : CgStmt stmt : ss)
-        (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
-
-  flatten (s:ss) =
-        case s of
-          CgStmt stmt -> (stmt:block,blocks)
-          CgLabel id  -> ([CmmBranch id],BasicBlock id block:blocks)
-          CgFork fork_id stmts ->
-                (block, BasicBlock fork_id fork_block : fork_blocks ++ blocks)
-                where (fork_block, fork_blocks) = flatten (fromOL stmts)
-    where (block,blocks) = flatten ss
-
-isJump :: CmmStmt -> Bool
-isJump (CmmJump   _ _) = True
-isJump (CmmBranch _  ) = True
-isJump (CmmSwitch _ _) = True
-isJump (CmmReturn    ) = True
-isJump _               = False
-
-isOrdinaryStmt :: CgStmt -> Bool
-isOrdinaryStmt (CgStmt _) = True
-isOrdinaryStmt _          = False
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-                Stack and heap models
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-type VirtualHpOffset = WordOff -- Both are in
-type VirtualSpOffset = WordOff -- units of words
-
--- | Stack usage information during code generation.
---
--- INVARIANT: The environment contains no Stable references to
---            stack slots below (lower offset) frameSp
---            It can contain volatile references to this area though.
-data StackUsage
-  = StackUsage {
-        virtSp :: VirtualSpOffset,
-                -- Virtual offset of topmost allocated slot
-
-        frameSp :: VirtualSpOffset,
-                -- Virtual offset of the return address of the enclosing frame.
-                -- This RA describes the liveness/pointedness of
-                -- all the stack from frameSp downwards
-                -- INVARIANT: less than or equal to virtSp
-
-         freeStk :: [VirtualSpOffset],
-                -- List of free slots, in *increasing* order
-                -- INVARIANT: all <= virtSp
-                --            All slots <= virtSp are taken except these ones
-
-         realSp :: VirtualSpOffset,
-                -- Virtual offset of real stack pointer register
-
-         hwSp :: VirtualSpOffset
-  }             -- Highest value ever taken by virtSp
-
--- | Heap usage information during code generation.
---
--- virtHp keeps track of the next location to allocate an object at. realHp
--- keeps track of what the Hp STG register actually points to. The reason these
--- aren't always the same is that we want to be able to move the realHp in one
--- go when allocating numerous objects to save having to bump it each time.
--- virtHp we do bump each time but it doesn't create corresponding inefficient
--- machine code.
-data HeapUsage
-  = HeapUsage {
-        virtHp :: VirtualHpOffset, -- Virtual offset of highest allocated word
-        realHp :: VirtualHpOffset  -- Virtual offset of real heap ptr
-  }
-
--- | Return the heap usage high water mark
-heapHWM :: HeapUsage -> VirtualHpOffset
-heapHWM = virtHp
-
-
--- | Initial stack usage
-initStkUsage :: StackUsage
-initStkUsage
-  = StackUsage {
-        virtSp  = 0,
-        frameSp = 0,
-        freeStk = [],
-        realSp  = 0,
-        hwSp    = 0
-  }
-
--- | Initial heap usage
-initHpUsage :: HeapUsage
-initHpUsage
-  = HeapUsage {
-        virtHp = 0,
-        realHp = 0
-  }
-
--- | @stateIncUsafe@ sets the stack and heap high water marks of $arg1$ to
--- be the max of the high water marks of $arg1$ and $arg2$.
-stateIncUsage :: CgState -> CgState -> CgState
-stateIncUsage s1 s2@(MkCgState { cgs_stk_usg = stk_usg, cgs_hp_usg = hp_usg })
-  = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg,
-         cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp   stk_usg }
-    `addCodeBlocksFrom` s2
-
--- | Similar to @stateIncUsafe@ but we don't max the heap high-watermark
--- because @stateIncUsageEval@ is used only in forkEval, which in turn is only
--- used for blocks of code which do their own heap-check.
-stateIncUsageEval :: CgState -> CgState -> CgState
-stateIncUsageEval s1 s2
-  = s1 { cgs_stk_usg = cgs_stk_usg s1 `maxStkHw` hwSp (cgs_stk_usg s2) }
-    `addCodeBlocksFrom` s2
-
--- | Add code blocks from the latter to the former
--- (The cgs_stmts will often be empty, but not always; see @codeOnly@)
-addCodeBlocksFrom :: CgState -> CgState -> CgState
-s1 `addCodeBlocksFrom` s2
-  = s1 { cgs_stmts = cgs_stmts s1 `appOL` cgs_stmts s2,
-         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
-
--- | Set @HeapUsage@ virtHp to max of current or $arg2$.
-maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
-hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
-
--- | Set @StackUsage@ hwSp to max of current or $arg2$.
-maxStkHw :: StackUsage -> VirtualSpOffset -> StackUsage
-stk_usg `maxStkHw` hw = stk_usg { hwSp = hwSp stk_usg `max` hw }
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-                The FCode monad
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
-type Code       = FCode ()
-
-instance Monad FCode where
-        (>>=)  = thenFC
-        return = returnFC
-
-{-# INLINE thenC #-}
-{-# INLINE thenFC #-}
-{-# INLINE returnFC #-}
-
-initC :: IO CgState
-initC  = do { uniqs <- mkSplitUniqSupply 'c'
-            ; return (initCgState uniqs) }
-
-runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
-runC dflags mod st (FCode code) = code (initCgInfoDown dflags mod) st
-
-returnFC :: a -> FCode a
-returnFC val = FCode $ \_ state -> (val, state)
-
-thenC :: Code -> FCode a -> FCode a
-thenC (FCode m) (FCode k) = FCode $ \info_down state ->
-    let (_,new_state) = m info_down state
-    in k info_down new_state
-
-listCs :: [Code] -> Code
-listCs []       = return ()
-listCs (fc:fcs) = fc >> listCs fcs
-
-mapCs :: (a -> Code) -> [a] -> Code
-mapCs = mapM_
-
-thenFC  :: FCode a -> (a -> FCode c) -> FCode c
-thenFC (FCode m) k = FCode $ \info_down state ->
-    let (m_result, new_state) = m info_down state
-        (FCode kcode)         = k m_result
-    in kcode info_down new_state
-
-listFCs :: [FCode a] -> FCode [a]
-listFCs = sequence
-
-mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
-mapFCs = mapM
-
--- | Knot-tying combinator for @FCode@
-fixC :: (a -> FCode a) -> FCode a
-fixC fcode = FCode $ \info_down state ->
-    let FCode fc     = fcode v
-        result@(v,_) = fc info_down state
-    in result
-
--- | Knot-tying combinator that throws result away
-fixC_ :: (a -> FCode a) -> FCode ()
-fixC_ fcode = fixC fcode >> return ()
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-        Operators for getting and setting the state and "info_down".
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-getState :: FCode CgState
-getState = FCode $ \_ state -> (state, state)
-
-setState :: CgState -> FCode ()
-setState state = FCode $ \_ _ -> ((), state)
-
-getStkUsage :: FCode StackUsage
-getStkUsage = do
-    state <- getState
-    return $ cgs_stk_usg state
-
-setStkUsage :: StackUsage -> Code
-setStkUsage new_stk_usg = do
-    state <- getState
-    setState $ state {cgs_stk_usg = new_stk_usg}
-
-getHpUsage :: FCode HeapUsage
-getHpUsage = do
-    state <- getState
-    return $ cgs_hp_usg state
-
-setHpUsage :: HeapUsage -> Code
-setHpUsage new_hp_usg = do
-    state <- getState
-    setState $ state {cgs_hp_usg = new_hp_usg}
-
-getBinds :: FCode CgBindings
-getBinds = do
-    state <- getState
-    return $ cgs_binds state
-
-setBinds :: CgBindings -> FCode ()
-setBinds new_binds = do
-    state <- getState
-    setState $ state {cgs_binds = new_binds}
-
-getStaticBinds :: FCode CgBindings
-getStaticBinds = do
-    info  <- getInfoDown
-    return (cgd_statics info)
-
-withState :: FCode a -> CgState -> FCode (a,CgState)
-withState (FCode fcode) newstate = FCode $ \info_down state ->
-    let (retval, state2) = fcode info_down newstate
-    in ((retval, state2), state)
-
-newUniqSupply :: FCode UniqSupply
-newUniqSupply = do
-    state <- getState
-    let (us1, us2) = splitUniqSupply (cgs_uniqs state)
-    setState $ state { cgs_uniqs = us1 }
-    return us2
-
-newUnique :: FCode Unique
-newUnique = do
-    us <- newUniqSupply
-    return (uniqFromSupply us)
-
-getInfoDown :: FCode CgInfoDownwards
-getInfoDown = FCode $ \info_down state -> (info_down, state)
-
-instance HasDynFlags FCode where
-    getDynFlags = liftM cgd_dflags getInfoDown
-
-getThisPackage :: FCode PackageId
-getThisPackage = liftM thisPackage getDynFlags
-
-withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
-withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
-
-doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
-doFCode (FCode fcode) info_down state = fcode info_down state
-\end{code}
-
-%************************************************************************
-%*                                                                      *
-                Forking
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-
--- | Takes code and compiles it in a completely fresh environment, except that
--- compilation info and statics are passed in unchanged. The current
--- environment is passed on completely unaltered, except that the Cmm code
--- from the fork is incorporated.
-forkClosureBody :: Code -> Code
-forkClosureBody body_code = do
-    info  <- getInfoDown
-    us    <- newUniqSupply
-    state <- getState
-    let body_info_down   = info { cgd_eob = initEobInfo }
-        ((), fork_state) = doFCode body_code body_info_down (initCgState us)
-
-    ASSERT( isNilOL (cgs_stmts fork_state) )
-      setState $ state `addCodeBlocksFrom` fork_state
-
--- | @forkStatics@ $fc$ compiles $fc$ in an environment whose statics come
--- from the current bindings, but which is otherwise freshly initialised.
--- The Cmm returned is attached to the current state, but the bindings and
--- usage information is otherwise unchanged.
-forkStatics :: FCode a -> FCode a
-forkStatics body_code = do
-    info  <- getInfoDown
-    us    <- newUniqSupply
-    state <- getState
-    let rhs_info_down = info { cgd_statics = cgs_binds state,
-                               cgd_eob     = initEobInfo }
-        (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us)
-
-    ASSERT( isNilOL (cgs_stmts fork_state_out) )
-      setState (state `addCodeBlocksFrom` fork_state_out)
-    return result
-
--- | @forkProc@ takes a code and compiles it in the current environment,
--- returning the basic blocks thus constructed. The current environment is
--- passed on completely unchanged. It is pretty similar to @getBlocks@, except
--- that the latter does affect the environment.
-forkProc :: Code -> FCode CgStmts
-forkProc body_code = do
-    info  <- getInfoDown
-    us    <- newUniqSupply
-    state <- getState
-    let fork_state_in = (initCgState us)
-                            { cgs_binds   = cgs_binds state,
-                              cgs_stk_usg = cgs_stk_usg state,
-                              cgs_hp_usg  = cgs_hp_usg state }
-        (code_blks, fork_state_out) = doFCode (getCgStmts body_code)
-                                              info fork_state_in
-    setState $ state `stateIncUsageEval` fork_state_out
-    return code_blks
-
--- Emit any code from the inner thing into the outer thing
--- Do not affect anything else in the outer state
--- Used in almost-circular code to prevent false loop dependencies
-codeOnly :: Code -> Code
-codeOnly body_code = do
-    info  <- getInfoDown
-    us    <- newUniqSupply
-    state <- getState
-    let fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state,
-                                           cgs_stk_usg = cgs_stk_usg state,
-                                           cgs_hp_usg  = cgs_hp_usg state }
-        ((), fork_state_out) = doFCode body_code info fork_state_in
-    setState $ state `addCodeBlocksFrom` fork_state_out
-
--- | @forkAlts@ $bs~d$ takes fcodes $bs$ for the branches of a @case@, and an
--- an fcode for the default case $d$, and compiles each in the current
--- environment. The current environment is passed on unmodified, except that:
---     * the worst stack high-water mark is incorporated
---     * the virtual Hp is moved on to the worst virtual Hp for the branches
-forkAlts :: [FCode a] -> FCode [a]
-forkAlts branch_fcodes = do 
-    info  <- getInfoDown
-    us    <- newUniqSupply
-    state <- getState
-    let compile us branch = (us2, doFCode branch info branch_state)
-            where
-                (us1,us2)    = splitUniqSupply us
-                branch_state = (initCgState us1) {
-                                   cgs_binds   = cgs_binds state,
-                                   cgs_stk_usg = cgs_stk_usg state,
-                                   cgs_hp_usg  = cgs_hp_usg state }
-        (_us, results) = mapAccumL compile us branch_fcodes
-        (branch_results, branch_out_states) = unzip results
-    -- NB foldl. state is the *left* argument to stateIncUsage
-    setState $ foldl stateIncUsage state branch_out_states
-    return branch_results
-
--- | @forkEval@ takes two blocks of code.
--- 
---   *  The first meddles with the environment to set it up as expected by
---      the alternatives of a @case@ which does an eval (or gc-possible primop).
---   *  The second block is the code for the alternatives.
---      (plus info for semi-tagging purposes)
---
--- @forkEval@ picks up the virtual stack pointer and returns a suitable
--- @EndOfBlockInfo@ for the caller to use, together with whatever value
--- is returned by the second block.
--- 
--- It uses @initEnvForAlternatives@ to initialise the environment, and
--- @stateIncUsageAlt@ to incorporate usage; the latter ignores the heap usage.
-forkEval :: EndOfBlockInfo       -- For the body
-         -> Code                 -- Code to set environment
-         -> FCode Sequel         -- Semi-tagging info to store
-         -> FCode EndOfBlockInfo -- The new end of block info
-forkEval body_eob_info env_code body_code = do
-    (v, sequel) <- forkEvalHelp body_eob_info env_code body_code
-    returnFC (EndOfBlockInfo v sequel)
-
--- A disturbingly complicated function
-forkEvalHelp :: EndOfBlockInfo  -- For the body
-             -> Code            -- Code to set environment
-             -> FCode a         -- The code to do after the eval
-             -> FCode (VirtualSpOffset, -- Sp
-                       a)               -- Result of the FCode
-forkEvalHelp body_eob_info env_code body_code = do
-    info  <- getInfoDown
-    us    <- newUniqSupply
-    state <- getState
-
-    let info_body      = info { cgd_eob = body_eob_info }
-        (_, env_state) = doFCode env_code info_body
-                                 (state {cgs_uniqs = us})
-        state_for_body = (initCgState (cgs_uniqs env_state))
-                            { cgs_binds   = binds_for_body,
-                              cgs_stk_usg = stk_usg_for_body }
-        binds_for_body   = nukeVolatileBinds (cgs_binds env_state)
-        stk_usg_from_env = cgs_stk_usg env_state
-        virtSp_from_env  = virtSp stk_usg_from_env
-        stk_usg_for_body = stk_usg_from_env { realSp = virtSp_from_env,
-                                              hwSp   = virtSp_from_env }
-        (value_returned, state_at_end_return)
-            = doFCode body_code info_body state_for_body
-
-    -- The code coming back should consist only of nested declarations,
-    -- notably of the return vector!
-    ASSERT( isNilOL (cgs_stmts state_at_end_return) )
-      setState $ state `stateIncUsageEval` state_at_end_return
-    return (virtSp_from_env, value_returned)
-
--- ----------------------------------------------------------------------------
--- Combinators for emitting code
-
-nopC :: Code
-nopC = return ()
-
-whenC :: Bool -> Code -> Code
-whenC True  code = code
-whenC False _    = nopC
-
--- Corresponds to 'emit' in new code generator with a smart constructor
--- from cmm/MkGraph.hs
-stmtC :: CmmStmt -> Code
-stmtC stmt = emitCgStmt (CgStmt stmt)
-
-labelC :: BlockId -> Code
-labelC id = emitCgStmt (CgLabel id)
-
-newLabelC :: FCode BlockId
-newLabelC = do
-    u <- newUnique
-    return $ mkBlockId u
-
--- Emit code, eliminating no-ops
-checkedAbsC :: CmmStmt -> Code
-checkedAbsC stmt = emitStmts $ if isNopStmt stmt then nilOL else unitOL stmt
-
-stmtsC :: [CmmStmt] -> Code
-stmtsC stmts = emitStmts $ toOL stmts
-
--- Emit code; no no-op checking
-emitStmts :: CmmStmts -> Code
-emitStmts stmts = emitCgStmts $ fmap CgStmt stmts
-
--- forkLabelledCode is for emitting a chunk of code with a label, outside
--- of the current instruction stream.
-forkLabelledCode :: Code -> FCode BlockId
-forkLabelledCode code = getCgStmts code >>= forkCgStmts
-
-emitCgStmt :: CgStmt -> Code
-emitCgStmt stmt = do
-    state <- getState
-    setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
-
-emitDecl :: CmmDecl -> Code
-emitDecl decl = do
-    state <- getState
-    setState $ state { cgs_tops = cgs_tops state `snocOL` decl }
-
-emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
-emitProc mb_info lbl [] blocks = do
-    let proc_block = CmmProc infos lbl (ListGraph blocks)
-    state <- getState
-    setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block }
-  where
-    infos = case (blocks,mb_info) of
-                (b:_, Just info) -> mapSingleton (blockId b) info
-                _other           -> mapEmpty
-
-emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
-
--- Emit a procedure whose body is the specified code; no info table
-emitSimpleProc :: CLabel -> Code -> Code
-emitSimpleProc lbl code = do
-    stmts <- getCgStmts code
-    blks <- cgStmtsToBlocks stmts
-    emitProc Nothing lbl [] blks
-
--- Get all the CmmTops (there should be no stmts)
--- Return a single Cmm which may be split from other Cmms by
--- object splitting (at a later stage)
-getCmm :: Code -> FCode CmmGroup
-getCmm code = do
-    state1 <- getState
-    ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
-    setState $ state2 { cgs_tops = cgs_tops state1 }
-    return (fromOL (cgs_tops state2))
-
--- ----------------------------------------------------------------------------
--- CgStmts
-
--- These functions deal in terms of CgStmts, which is an abstract type
--- representing the code in the current proc.
-
--- emit CgStmts into the current instruction stream
-emitCgStmts :: CgStmts -> Code
-emitCgStmts stmts = do
-    state <- getState
-    setState $ state { cgs_stmts = cgs_stmts state `appOL` stmts }
-
--- emit CgStmts outside the current instruction stream, and return a label
-forkCgStmts :: CgStmts -> FCode BlockId
-forkCgStmts stmts = do
-    id <- newLabelC
-    emitCgStmt (CgFork id stmts)
-    return id
-
--- turn CgStmts into [CmmBasicBlock], for making a new proc.
-cgStmtsToBlocks :: CgStmts -> FCode [CmmBasicBlock]
-cgStmtsToBlocks stmts = do
-    id <- newLabelC
-    return (flattenCgStmts id stmts)
-
--- collect the code emitted by an FCode computation
-getCgStmts' :: FCode a -> FCode (a, CgStmts)
-getCgStmts' fcode = do
-    state1 <- getState
-    (a, state2) <- withState fcode (state1 { cgs_stmts = nilOL })
-    setState $ state2 { cgs_stmts = cgs_stmts state1  }
-    return (a, cgs_stmts state2)
-
-getCgStmts :: FCode a -> FCode CgStmts
-getCgStmts fcode = do
-    (_,stmts) <- getCgStmts' fcode
-    return stmts
-
--- Simple ways to construct CgStmts:
-noCgStmts :: CgStmts
-noCgStmts = nilOL
-
-oneCgStmt :: CmmStmt -> CgStmts
-oneCgStmt stmt = unitOL (CgStmt stmt)
-
-consCgStmt :: CmmStmt -> CgStmts -> CgStmts
-consCgStmt stmt stmts = CgStmt stmt `consOL` stmts
-
--- ----------------------------------------------------------------------------
--- Get the current module name
-
-getModuleName :: FCode Module
-getModuleName = do
-    info <- getInfoDown
-    return (cgd_mod info)
-
--- ----------------------------------------------------------------------------
--- Get/set the end-of-block info
-
-setEndOfBlockInfo :: EndOfBlockInfo -> Code -> Code
-setEndOfBlockInfo eob_info code = do
-    info  <- getInfoDown
-    withInfoDown code (info {cgd_eob = eob_info})
-
-getEndOfBlockInfo :: FCode EndOfBlockInfo
-getEndOfBlockInfo = do
-    info <- getInfoDown
-    return (cgd_eob info)
-
--- ----------------------------------------------------------------------------
--- Get/set the current SRT label
-
--- There is just one SRT for each top level binding; all the nested
--- bindings use sub-sections of this SRT. The label is passed down to
--- the nested bindings via the monad.
-
-getSRTLabel :: FCode CLabel     -- Used only by cgPanic
-getSRTLabel = do
-    info  <- getInfoDown
-    return (cgd_srt_lbl info)
-
-setSRTLabel :: CLabel -> FCode a -> FCode a
-setSRTLabel srt_lbl code = do
-    info <- getInfoDown
-    withInfoDown code (info { cgd_srt_lbl = srt_lbl})
-
-getSRT :: FCode SRT
-getSRT = do
-    info <- getInfoDown
-    return (cgd_srt info)
-
-setSRT :: SRT -> FCode a -> FCode a
-setSRT srt code = do
-    info <- getInfoDown
-    withInfoDown code (info { cgd_srt = srt})
-
--- ----------------------------------------------------------------------------
--- Get/set the current ticky counter label
-
-getTickyCtrLabel :: FCode CLabel
-getTickyCtrLabel = do
-    info <- getInfoDown
-    return (cgd_ticky info)
-
-setTickyCtrLabel :: CLabel -> Code -> Code
-setTickyCtrLabel ticky code = do
-    info <- getInfoDown
-    withInfoDown code (info {cgd_ticky = ticky})
-\end{code}
diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs
deleted file mode 100644 (file)
index 0e642cb..0000000
+++ /dev/null
@@ -1,100 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow -2006
---
--- Code generation relaed to GpH
---      (a) parallel
---      (b) GranSim
---
------------------------------------------------------------------------------
-
-module CgParallel(
-        staticGranHdr,staticParHdr,
-        granFetchAndReschedule, granYield,
-        doGranAllocate
-  ) where
-
-import CgMonad
-import CgCallConv
-import DynFlags
-import Id
-import OldCmm
-import Outputable
-import SMRep
-
-import Control.Monad
-
-staticParHdr :: [CmmLit]
--- Parallel header words in a static closure
-staticParHdr = []
-
---------------------------------------------------------
---              GranSim stuff
---------------------------------------------------------
-
-staticGranHdr :: [CmmLit]
--- Gransim header words in a static closure
-staticGranHdr = []
-
-doGranAllocate :: CmmExpr -> Code
--- macro DO_GRAN_ALLOCATE
-doGranAllocate _hp
-  = do dflags <- getDynFlags
-       when (gopt Opt_GranMacros dflags) $ panic "doGranAllocate"
-
-
-
--------------------------
-granFetchAndReschedule :: [(Id,GlobalReg)]  -- Live registers
-                       -> Bool                  -- Node reqd?
-                       -> Code
--- Emit code for simulating a fetch and then reschedule.
-granFetchAndReschedule regs node_reqd
-  = do dflags <- getDynFlags
-       let liveness = mkRegLiveness dflags regs 0 0
-       when (gopt Opt_GranMacros dflags &&
-             (node `elem` map snd regs || node_reqd)) $
-           do fetch
-              reschedule liveness node_reqd
-
-fetch :: FCode ()
-fetch = panic "granFetch"
-        -- Was: absC (CMacroStmt GRAN_FETCH [])
-        --HWL: generate GRAN_FETCH macro for GrAnSim
-        --     currently GRAN_FETCH and GRAN_FETCH_AND_RESCHEDULE are miai
-
-reschedule :: StgWord -> Bool -> Code
-reschedule _liveness _node_reqd = panic "granReschedule"
-        -- Was: absC  (CMacroStmt GRAN_RESCHEDULE [
-        --                mkIntCLit (I# (word2Int# liveness_mask)),
-        --                mkIntCLit (if node_reqd then 1 else 0)])
-
-
--------------------------
--- The @GRAN_YIELD@ macro is taken from JSM's  code for Concurrent Haskell. It
--- allows to context-switch at  places where @node@ is  not alive (it uses the
--- @Continue@ rather  than the @EnterNodeCode@  function in the  RTS). We emit
--- this kind of macro at the beginning of the following kinds of basic bocks:
--- \begin{itemize}
---  \item Slow entry code where node is not alive (see @CgClosure.lhs@). Normally
---        we use @fetchAndReschedule@ at a slow entry code.
---  \item Fast entry code (see @CgClosure.lhs@).
---  \item Alternatives in case expressions (@CLabelledCode@ structures), provided
---        that they are not inlined (see @CgCases.lhs@). These alternatives will
---        be turned into separate functions.
-
-granYield :: [(Id,GlobalReg)]   -- Live registers
-          -> Bool               -- Node reqd?
-          -> Code
-
-granYield regs node_reqd
-  = do dflags <- getDynFlags
-       let liveness = mkRegLiveness dflags regs 0 0
-       when (gopt Opt_GranMacros dflags && node_reqd) $ yield liveness
-
-yield :: StgWord -> Code
-yield _liveness = panic "granYield"
-        -- Was : absC (CMacroStmt GRAN_YIELD
-        --                  [mkIntCLit (I# (word2Int# liveness_mask))])
-
-
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
deleted file mode 100644 (file)
index 6185a2b..0000000
+++ /dev/null
@@ -1,1177 +0,0 @@
------------------------------------------------------------------------------
---
--- Code generation for PrimOps.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module CgPrimOp (
-        cgPrimOp
-    ) where
-
-import BasicTypes
-import ForeignCall
-import ClosureInfo
-import StgSyn
-import CgForeignCall
-import CgBindery
-import CgMonad
-import CgHeapery
-import CgInfoTbls
-import CgTicky
-import CgProf
-import CgUtils
-import OldCmm
-import CLabel
-import OldCmmUtils
-import PrimOp
-import SMRep
-import Module
-import Outputable
-import DynFlags
-import FastString
-
-import Control.Monad
-import Data.Bits
-
--- ---------------------------------------------------------------------------
--- Code generation for PrimOps
-
-cgPrimOp :: [CmmFormal]       -- where to put the results
-         -> PrimOp            -- the op
-         -> [StgArg]          -- arguments
-         -> StgLiveVars       -- live vars, in case we need to save them
-         -> Code
-
-cgPrimOp results op args live
-  = do dflags <- getDynFlags
-       arg_exprs <- getArgAmodes args
-       let non_void_args = [ e | (r,e) <- arg_exprs, nonVoidArg r ]
-       emitPrimOp dflags results op non_void_args live
-
-
-emitPrimOp :: DynFlags
-           -> [CmmFormal]       -- where to put the results
-           -> PrimOp            -- the op
-           -> [CmmExpr]         -- arguments
-           -> StgLiveVars       -- live vars, in case we need to save them
-           -> Code
-
---  First we handle various awkward cases specially.  The remaining
--- easy cases are then handled by translateOp, defined below.
-
-emitPrimOp dflags [res_r,res_c] IntAddCOp [aa,bb] _
-{-
-   With some bit-twiddling, we can define int{Add,Sub}Czh portably in
-   C, and without needing any comparisons.  This may not be the
-   fastest way to do it - if you have better code, please send it! --SDM
-
-   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
-
-   We currently don't make use of the r value if c is != 0 (i.e.
-   overflow), we just convert to big integers and try again.  This
-   could be improved by making r and c the correct values for
-   plugging into a new J#.
-
-   { r = ((I_)(a)) + ((I_)(b));                                 \
-     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
-         >> (BITS_IN (I_) - 1);                                 \
-   }
-   Wading through the mass of bracketry, it seems to reduce to:
-   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
-
--}
-   = stmtsC [
-        CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
-        CmmAssign (CmmLocal res_c) $
-          CmmMachOp (mo_wordUShr dflags) [
-                CmmMachOp (mo_wordAnd dflags) [
-                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
-                ],
-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
-          ]
-     ]
-
-
-emitPrimOp dflags [res_r,res_c] IntSubCOp [aa,bb] _
-{- Similarly:
-   #define subIntCzh(r,c,a,b)                                   \
-   { r = ((I_)(a)) - ((I_)(b));                                 \
-     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
-         >> (BITS_IN (I_) - 1);                                 \
-   }
-
-   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
--}
-   = stmtsC [
-        CmmAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
-        CmmAssign (CmmLocal res_c) $
-          CmmMachOp (mo_wordUShr dflags) [
-                CmmMachOp (mo_wordAnd dflags) [
-                    CmmMachOp (mo_wordXor dflags) [aa,bb],
-                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
-                ],
-                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
-          ]
-     ]
-
-
-emitPrimOp _      [res] ParOp [arg] live
-  = do
-        -- for now, just implement this in a C function
-        -- later, we might want to inline it.
-    vols <- getVolatileRegs live
-    emitForeignCall' PlayRisky
-        [CmmHinted res NoHint]
-        (CmmCallee newspark CCallConv)
-        [   (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
-          , (CmmHinted arg AddrHint)  ]
-        (Just vols)
-        NoC_SRT -- No SRT b/c we do PlayRisky
-        CmmMayReturn
-  where
-        newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
-
-emitPrimOp dflags [res] SparkOp [arg] live = do
-    -- returns the value of arg in res.  We're going to therefore
-    -- refer to arg twice (once to pass to newSpark(), and once to
-    -- assign to res), so put it in a temporary.
-    tmp <- newTemp (bWord dflags)
-    stmtC (CmmAssign (CmmLocal tmp) arg)
-
-    vols <- getVolatileRegs live
-    res' <- newTemp (bWord dflags)
-    emitForeignCall' PlayRisky
-        [CmmHinted res' NoHint]
-        (CmmCallee newspark CCallConv)
-        [   (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
-          , (CmmHinted arg AddrHint)  ]
-        (Just vols)
-        NoC_SRT -- No SRT b/c we do PlayRisky
-        CmmMayReturn
-    stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
-  where
-        newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))
-
-emitPrimOp dflags [res] GetCCSOfOp [arg] _live
-  = stmtC (CmmAssign (CmmLocal res) val)
-  where
-    val
-     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
-     | otherwise                      = CmmLit (zeroCLit dflags)
-
-emitPrimOp _      [res] GetCurrentCCSOp [_dummy_arg] _live
-   = stmtC (CmmAssign (CmmLocal res) curCCS)
-
-emitPrimOp dflags [res] ReadMutVarOp [mutv] _
-   = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSize dflags) (gcWord dflags)))
-
-emitPrimOp dflags [] WriteMutVarOp [mutv,var] live
-   = do stmtC (CmmStore (cmmOffsetW dflags mutv (fixedHdrSize dflags)) var)
-        vols <- getVolatileRegs live
-        emitForeignCall' PlayRisky
-                [{-no results-}]
-                (CmmCallee (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
-                         CCallConv)
-                [   (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint)
-                  , (CmmHinted mutv AddrHint)  ]
-                (Just vols)
-                NoC_SRT -- No SRT b/c we do PlayRisky
-                CmmMayReturn
-
---  #define sizzeofByteArrayzh(r,a) \
---     r = ((StgArrWords *)(a))->bytes
-emitPrimOp dflags [res] SizeofByteArrayOp [arg] _
-   = stmtC $
-         CmmAssign (CmmLocal res)
-                   (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags))
-
---  #define sizzeofMutableByteArrayzh(r,a) \
---      r = ((StgArrWords *)(a))->bytes
-emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg] live
-   = emitPrimOp dflags [res] SizeofByteArrayOp [arg] live
-
-
---  #define touchzh(o)                  /* nothing */
-emitPrimOp _      [] TouchOp [_] _
-   = nopC
-
---  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
-emitPrimOp dflags [res] ByteArrayContents_Char [arg] _
-   = stmtC (CmmAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags)))
-
---  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
-emitPrimOp dflags [res] StableNameToIntOp [arg] _
-   = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSize dflags) (bWord dflags)))
-
---  #define eqStableNamezh(r,sn1,sn2)                                   \
---    (r = (((StgStableName *)sn1)->sn == ((StgStableName *)sn2)->sn))
-emitPrimOp dflags [res] EqStableNameOp [arg1,arg2] _
-   = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [
-                             cmmLoadIndexW dflags arg1 (fixedHdrSize dflags) (bWord dflags),
-                             cmmLoadIndexW dflags arg2 (fixedHdrSize dflags) (bWord dflags)
-                      ]))
-
-
-emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2] _
-   = stmtC (CmmAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2]))
-
---  #define addrToHValuezh(r,a) r=(P_)a
-emitPrimOp _      [res] AddrToAnyOp [arg] _
-   = stmtC (CmmAssign (CmmLocal res) arg)
-
---  #define dataToTagzh(r,a)  r=(GET_TAG(((StgClosure *)a)->header.info))
---  Note: argument may be tagged!
-emitPrimOp dflags [res] DataToTagOp [arg] _
-   = stmtC (CmmAssign (CmmLocal res) (getConstrTag dflags (cmmUntag dflags arg)))
-
-{- Freezing arrays-of-ptrs requires changing an info table, for the
-   benefit of the generational collector.  It needs to scavenge mutable
-   objects, even if they are in old space.  When they become immutable,
-   they can be removed from this scavenge list.  -}
-
---  #define unsafeFreezzeArrayzh(r,a)
---      {
---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN0_info);
---        r = a;
---      }
-emitPrimOp _      [res] UnsafeFreezeArrayOp [arg] _
-   = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
-       CmmAssign (CmmLocal res) arg ]
-emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg] _
-   = stmtsC [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_infoLabel)),
-       CmmAssign (CmmLocal res) arg ]
-
---  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
-emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg] _
-   = stmtC (CmmAssign (CmmLocal res) arg)
-
-emitPrimOp _      [] CopyArrayOp [src,src_off,dst,dst_off,n] live =
-    doCopyArrayOp src src_off dst dst_off n live
-emitPrimOp _      [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live =
-    doCopyMutableArrayOp src src_off dst dst_off n live
-emitPrimOp _      [res] CloneArrayOp [src,src_off,n] live =
-    emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
-emitPrimOp _      [res] CloneMutableArrayOp [src,src_off,n] live =
-    emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
-emitPrimOp _      [res] FreezeArrayOp [src,src_off,n] live =
-    emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
-emitPrimOp _      [res] ThawArrayOp [src,src_off,n] live =
-    emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
-
-emitPrimOp _      [] CopyArrayArrayOp [src,src_off,dst,dst_off,n] live =
-    doCopyArrayOp src src_off dst dst_off n live
-emitPrimOp _      [] CopyMutableArrayArrayOp [src,src_off,dst,dst_off,n] live =
-    doCopyMutableArrayOp src src_off dst dst_off n live
-
--- Reading/writing pointer arrays
-
-emitPrimOp _      [r] ReadArrayOp  [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      [r] IndexArrayOp [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      []  WriteArrayOp [obj,ix,v] _  = doWritePtrArrayOp obj ix v
-
-emitPrimOp _      [r] IndexArrayArrayOp_ByteArray         [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      [r] IndexArrayArrayOp_ArrayArray        [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      [r] ReadArrayArrayOp_ByteArray          [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      [r] ReadArrayArrayOp_MutableByteArray   [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      [r] ReadArrayArrayOp_ArrayArray         [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      [r] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   _  = doReadPtrArrayOp r obj ix
-emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] _  = doWritePtrArrayOp obj ix v
-emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] _  = doWritePtrArrayOp obj ix v
-emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] _  = doWritePtrArrayOp obj ix v
-emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] _  = doWritePtrArrayOp obj ix v
-
-emitPrimOp dflags [res] SizeofArrayOp [arg] _
-   = stmtC $ CmmAssign (CmmLocal res)
-                       (cmmLoadIndexW dflags arg (fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) (bWord dflags))
-emitPrimOp dflags [res] SizeofMutableArrayOp [arg] live
-   = emitPrimOp dflags [res] SizeofArrayOp [arg] live
-emitPrimOp dflags [res] SizeofArrayArrayOp [arg] live
-   = emitPrimOp dflags [res] SizeofArrayOp [arg] live
-emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg] live
-   = emitPrimOp dflags [res] SizeofArrayOp [arg] live
-
--- IndexXXXoffAddr
-
-emitPrimOp dflags res IndexOffAddrOp_Char      args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res IndexOffAddrOp_WideChar  args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res IndexOffAddrOp_Int       args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexOffAddrOp_Word      args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexOffAddrOp_Addr      args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _      res IndexOffAddrOp_Float     args _ = doIndexOffAddrOp Nothing f32 res args
-emitPrimOp _      res IndexOffAddrOp_Double    args _ = doIndexOffAddrOp Nothing f64 res args
-emitPrimOp dflags res IndexOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexOffAddrOp_Int8      args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags))  b8  res args
-emitPrimOp dflags res IndexOffAddrOp_Int16     args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
-emitPrimOp dflags res IndexOffAddrOp_Int32     args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
-emitPrimOp _      res IndexOffAddrOp_Int64     args _ = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp dflags res IndexOffAddrOp_Word8     args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8   res args
-emitPrimOp dflags res IndexOffAddrOp_Word16    args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
-emitPrimOp dflags res IndexOffAddrOp_Word32    args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp _      res IndexOffAddrOp_Word64    args _ = doIndexOffAddrOp Nothing b64 res args
-
--- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
-
-emitPrimOp dflags res ReadOffAddrOp_Char      args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res ReadOffAddrOp_WideChar  args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res ReadOffAddrOp_Int       args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadOffAddrOp_Word      args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadOffAddrOp_Addr      args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _      res ReadOffAddrOp_Float     args _ = doIndexOffAddrOp Nothing f32 res args
-emitPrimOp _      res ReadOffAddrOp_Double    args _ = doIndexOffAddrOp Nothing f64 res args
-emitPrimOp dflags res ReadOffAddrOp_StablePtr args _ = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadOffAddrOp_Int8      args _ = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadOffAddrOp_Int16     args _ = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
-emitPrimOp dflags res ReadOffAddrOp_Int32     args _ = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
-emitPrimOp _      res ReadOffAddrOp_Int64     args _ = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp dflags res ReadOffAddrOp_Word8     args _ = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadOffAddrOp_Word16    args _ = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
-emitPrimOp dflags res ReadOffAddrOp_Word32    args _ = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp _      res ReadOffAddrOp_Word64    args _ = doIndexOffAddrOp Nothing b64 res args
-
--- IndexXXXArray
-
-emitPrimOp dflags res IndexByteArrayOp_Char      args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res IndexByteArrayOp_WideChar  args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res IndexByteArrayOp_Int       args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexByteArrayOp_Word      args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexByteArrayOp_Addr      args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _      res IndexByteArrayOp_Float     args _ = doIndexByteArrayOp Nothing f32 res args
-emitPrimOp _      res IndexByteArrayOp_Double    args _ = doIndexByteArrayOp Nothing f64 res args
-emitPrimOp dflags res IndexByteArrayOp_StablePtr args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexByteArrayOp_Int8      args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8  res args
-emitPrimOp dflags res IndexByteArrayOp_Int16     args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16  res args
-emitPrimOp dflags res IndexByteArrayOp_Int32     args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32  res args
-emitPrimOp _      res IndexByteArrayOp_Int64     args _ = doIndexByteArrayOp Nothing b64  res args
-emitPrimOp dflags res IndexByteArrayOp_Word8     args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8  res args
-emitPrimOp dflags res IndexByteArrayOp_Word16    args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16  res args
-emitPrimOp dflags res IndexByteArrayOp_Word32    args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32  res args
-emitPrimOp _      res IndexByteArrayOp_Word64    args _ = doIndexByteArrayOp Nothing b64  res args
-
--- ReadXXXArray, identical to IndexXXXArray.
-
-emitPrimOp dflags res ReadByteArrayOp_Char       args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res ReadByteArrayOp_WideChar   args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res ReadByteArrayOp_Int        args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadByteArrayOp_Word       args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadByteArrayOp_Addr       args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _      res ReadByteArrayOp_Float      args _ = doIndexByteArrayOp Nothing f32 res args
-emitPrimOp _      res ReadByteArrayOp_Double     args _ = doIndexByteArrayOp Nothing f64 res args
-emitPrimOp dflags res ReadByteArrayOp_StablePtr  args _ = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadByteArrayOp_Int8       args _ = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadByteArrayOp_Int16      args _ = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16  res args
-emitPrimOp dflags res ReadByteArrayOp_Int32      args _ = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32  res args
-emitPrimOp _      res ReadByteArrayOp_Int64      args _ = doIndexByteArrayOp Nothing b64  res args
-emitPrimOp dflags res ReadByteArrayOp_Word8      args _ = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadByteArrayOp_Word16     args _ = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16  res args
-emitPrimOp dflags res ReadByteArrayOp_Word32     args _ = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32  res args
-emitPrimOp _      res ReadByteArrayOp_Word64     args _ = doIndexByteArrayOp Nothing b64  res args
-
--- WriteXXXoffAddr
-
-emitPrimOp dflags res WriteOffAddrOp_Char       args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8 res args
-emitPrimOp dflags res WriteOffAddrOp_WideChar   args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
-emitPrimOp dflags res WriteOffAddrOp_Int        args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res WriteOffAddrOp_Word       args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res WriteOffAddrOp_Addr       args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _      res WriteOffAddrOp_Float      args _ = doWriteOffAddrOp Nothing f32 res args
-emitPrimOp _      res WriteOffAddrOp_Double     args _ = doWriteOffAddrOp Nothing f64 res args
-emitPrimOp dflags res WriteOffAddrOp_StablePtr  args _ = doWriteOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res WriteOffAddrOp_Int8       args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8  res args
-emitPrimOp dflags res WriteOffAddrOp_Int16      args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
-emitPrimOp dflags res WriteOffAddrOp_Int32      args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
-emitPrimOp _      res WriteOffAddrOp_Int64      args _ = doWriteOffAddrOp Nothing b64 res args
-emitPrimOp dflags res WriteOffAddrOp_Word8      args _ = doWriteOffAddrOp (Just (mo_WordTo8 dflags)) b8  res args
-emitPrimOp dflags res WriteOffAddrOp_Word16     args _ = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
-emitPrimOp dflags res WriteOffAddrOp_Word32     args _ = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
-emitPrimOp _      res WriteOffAddrOp_Word64     args _ = doWriteOffAddrOp Nothing b64 res args
-
--- WriteXXXArray
-
-emitPrimOp dflags res WriteByteArrayOp_Char      args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8 res args
-emitPrimOp dflags res WriteByteArrayOp_WideChar  args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
-emitPrimOp dflags res WriteByteArrayOp_Int       args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res WriteByteArrayOp_Word      args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res WriteByteArrayOp_Addr      args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _      res WriteByteArrayOp_Float     args _ = doWriteByteArrayOp Nothing f32 res args
-emitPrimOp _      res WriteByteArrayOp_Double    args _ = doWriteByteArrayOp Nothing f64 res args
-emitPrimOp dflags res WriteByteArrayOp_StablePtr args _ = doWriteByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res WriteByteArrayOp_Int8      args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8  res args
-emitPrimOp dflags res WriteByteArrayOp_Int16     args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16  res args
-emitPrimOp dflags res WriteByteArrayOp_Int32     args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32  res args
-emitPrimOp _      res WriteByteArrayOp_Int64     args _ = doWriteByteArrayOp Nothing b64  res args
-emitPrimOp dflags res WriteByteArrayOp_Word8     args _ = doWriteByteArrayOp (Just (mo_WordTo8 dflags)) b8  res args
-emitPrimOp dflags res WriteByteArrayOp_Word16    args _ = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16  res args
-emitPrimOp dflags res WriteByteArrayOp_Word32    args _ = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32  res args
-emitPrimOp _      res WriteByteArrayOp_Word64    args _ = doWriteByteArrayOp Nothing b64  res args
-
--- Copying and setting byte arrays
-
-emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live =
-    doCopyByteArrayOp src src_off dst dst_off n live
-emitPrimOp _ [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live =
-    doCopyMutableByteArrayOp src src_off dst dst_off n live
-emitPrimOp _ [] SetByteArrayOp [ba,off,len,c] live =
-    doSetByteArrayOp ba off len c live
-
--- Population count.
--- The type of the primop takes a Word#, so we have to be careful to narrow
--- to the correct width before calling the primop.  Otherwise this can result
--- in a crash e.g. when calling the helper hs_popcnt8() which assumes that the
--- argument is <=0xff.
-emitPrimOp dflags [res] PopCnt8Op [w] live =
-  emitPopCntCall res (CmmMachOp (mo_WordTo8 dflags) [w]) W8 live
-emitPrimOp dflags [res] PopCnt16Op [w] live =
-  emitPopCntCall res (CmmMachOp (mo_WordTo16 dflags) [w]) W16 live
-emitPrimOp dflags [res] PopCnt32Op [w] live =
-  emitPopCntCall res (CmmMachOp (mo_WordTo32 dflags) [w]) W32 live
-emitPrimOp dflags [res] PopCnt64Op [w] live =
-  emitPopCntCall res (CmmMachOp (mo_WordTo64 dflags) [w]) W64 live
-emitPrimOp dflags [res] PopCntOp [w] live =
-  emitPopCntCall res w (wordWidth dflags) live
-
--- The rest just translate straightforwardly
-emitPrimOp dflags [res] op [arg] _
-   | nopOp op
-   = stmtC (CmmAssign (CmmLocal res) arg)
-
-   | Just (mop,rep) <- narrowOp op
-   = stmtC (CmmAssign (CmmLocal res) $
-            CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]])
-
-emitPrimOp dflags [res] op args live
-   | Just prim <- callishOp op
-   = do vols <- getVolatileRegs live
-        emitForeignCall' PlayRisky
-           [CmmHinted res NoHint]
-           (CmmPrim prim Nothing)
-           [CmmHinted a NoHint | a<-args]  -- ToDo: hints?
-           (Just vols)
-           NoC_SRT -- No SRT b/c we do PlayRisky
-           CmmMayReturn
-
-   | Just mop <- translateOp dflags op
-   = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in
-     stmtC stmt
-
-emitPrimOp dflags [res_q, res_r] IntQuotRemOp [arg_x, arg_y] _
-    = let genericImpl
-              = [CmmAssign (CmmLocal res_q)
-                           (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]),
-                 CmmAssign (CmmLocal res_r)
-                           (CmmMachOp (MO_S_Rem  (wordWidth dflags)) [arg_x, arg_y])]
-          stmt = CmmCall (CmmPrim (MO_S_QuotRem (wordWidth dflags)) (Just genericImpl))
-                         [CmmHinted res_q NoHint,
-                          CmmHinted res_r NoHint]
-                         [CmmHinted arg_x NoHint,
-                          CmmHinted arg_y NoHint]
-                         CmmMayReturn
-      in stmtC stmt
-emitPrimOp dflags [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
-    = let genericImpl
-              = [CmmAssign (CmmLocal res_q)
-                           (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]),
-                 CmmAssign (CmmLocal res_r)
-                           (CmmMachOp (MO_U_Rem  (wordWidth dflags)) [arg_x, arg_y])]
-          stmt = CmmCall (CmmPrim (MO_U_QuotRem (wordWidth dflags)) (Just genericImpl))
-                         [CmmHinted res_q NoHint,
-                          CmmHinted res_r NoHint]
-                         [CmmHinted arg_x NoHint,
-                          CmmHinted arg_y NoHint]
-                         CmmMayReturn
-      in stmtC stmt
-emitPrimOp dflags [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _
-    = do let ty = cmmExprType dflags arg_x_high
-             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]
-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
-             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]
-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]
-             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]
-             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]
-             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]
-             zero   = lit 0
-             one    = lit 1
-             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
-             lit i = CmmLit (CmmInt i (wordWidth dflags))
-             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt]
-             f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc,
-                                      CmmAssign (CmmLocal res_r) high]
-             f i acc high low =
-                 do roverflowedBit <- newLocalReg ty
-                    rhigh'         <- newLocalReg ty
-                    rhigh''        <- newLocalReg ty
-                    rlow'          <- newLocalReg ty
-                    risge          <- newLocalReg ty
-                    racc'          <- newLocalReg ty
-                    let high'         = CmmReg (CmmLocal rhigh')
-                        isge          = CmmReg (CmmLocal risge)
-                        overflowedBit = CmmReg (CmmLocal roverflowedBit)
-                    let this = [CmmAssign (CmmLocal roverflowedBit)
-                                          (shr high negone),
-                                CmmAssign (CmmLocal rhigh')
-                                          (or (shl high one) (shr low negone)),
-                                CmmAssign (CmmLocal rlow')
-                                          (shl low one),
-                                CmmAssign (CmmLocal risge)
-                                          (or (overflowedBit `ne` zero)
-                                              (high' `ge` arg_y)),
-                                CmmAssign (CmmLocal rhigh'')
-                                          (high' `minus` (arg_y `times` isge)),
-                                CmmAssign (CmmLocal racc')
-                                          (or (shl acc one) isge)]
-                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))
-                                      (CmmReg (CmmLocal rhigh''))
-                                      (CmmReg (CmmLocal rlow'))
-                    return (this ++ rest)
-         genericImpl <- f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
-         let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 (wordWidth dflags)) (Just genericImpl))
-                            [CmmHinted res_q NoHint,
-                             CmmHinted res_r NoHint]
-                            [CmmHinted arg_x_high NoHint,
-                             CmmHinted arg_x_low NoHint,
-                             CmmHinted arg_y NoHint]
-                            CmmMayReturn
-         stmtC stmt
-
-emitPrimOp dflags [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
- = do r1 <- newLocalReg (cmmExprType dflags arg_x)
-      r2 <- newLocalReg (cmmExprType dflags arg_x)
-      -- This generic implementation is very simple and slow. We might
-      -- well be able to do better, but for now this at least works.
-      let genericImpl
-           = [CmmAssign (CmmLocal r1)
-                  (add (bottomHalf arg_x) (bottomHalf arg_y)),
-              CmmAssign (CmmLocal r2)
-                  (add (topHalf (CmmReg (CmmLocal r1)))
-                       (add (topHalf arg_x) (topHalf arg_y))),
-              CmmAssign (CmmLocal res_h)
-                  (topHalf (CmmReg (CmmLocal r2))),
-              CmmAssign (CmmLocal res_l)
-                  (or (toTopHalf (CmmReg (CmmLocal r2)))
-                      (bottomHalf (CmmReg (CmmLocal r1))))]
-               where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
-                     toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
-                     bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
-                     add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
-                     or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
-                     hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
-                                          (wordWidth dflags))
-                     hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
-          stmt = CmmCall (CmmPrim (MO_Add2 (wordWidth dflags)) (Just genericImpl))
-                         [CmmHinted res_h NoHint,
-                          CmmHinted res_l NoHint]
-                         [CmmHinted arg_x NoHint,
-                          CmmHinted arg_y NoHint]
-                         CmmMayReturn
-      stmtC stmt
-emitPrimOp dflags [res_h, res_l] WordMul2Op [arg_x, arg_y] _
- = do let t = cmmExprType dflags arg_x
-      xlyl <- liftM CmmLocal $ newLocalReg t
-      xlyh <- liftM CmmLocal $ newLocalReg t
-      xhyl <- liftM CmmLocal $ newLocalReg t
-      r    <- liftM CmmLocal $ newLocalReg t
-      -- This generic implementation is very simple and slow. We might
-      -- well be able to do better, but for now this at least works.
-      let genericImpl
-           = [CmmAssign xlyl
-                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),
-              CmmAssign xlyh
-                  (mul (bottomHalf arg_x) (topHalf arg_y)),
-              CmmAssign xhyl
-                  (mul (topHalf arg_x) (bottomHalf arg_y)),
-              CmmAssign r
-                  (sum [topHalf    (CmmReg xlyl),
-                        bottomHalf (CmmReg xhyl),
-                        bottomHalf (CmmReg xlyh)]),
-              CmmAssign (CmmLocal res_l)
-                  (or (bottomHalf (CmmReg xlyl))
-                      (toTopHalf (CmmReg r))),
-              CmmAssign (CmmLocal res_h)
-                  (sum [mul (topHalf arg_x) (topHalf arg_y),
-                        topHalf (CmmReg xhyl),
-                        topHalf (CmmReg xlyh),
-                        topHalf (CmmReg r)])]
-               where topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
-                     toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
-                     bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
-                     add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
-                     sum = foldl1 add
-                     mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
-                     or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
-                     hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
-                                          (wordWidth dflags))
-                     hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
-          stmt = CmmCall (CmmPrim (MO_U_Mul2 (wordWidth dflags)) (Just genericImpl))
-                         [CmmHinted res_h NoHint,
-                          CmmHinted res_l NoHint]
-                         [CmmHinted arg_x NoHint,
-                          CmmHinted arg_y NoHint]
-                         CmmMayReturn
-      stmtC stmt
-
-emitPrimOp _ _ op _ _
- = pprPanic "emitPrimOp: can't translate PrimOp" (ppr op)
-
-newLocalReg :: CmmType -> FCode LocalReg
-newLocalReg t = do u <- newUnique
-                   return $ LocalReg u t
-
--- These PrimOps are NOPs in Cmm
-
-nopOp :: PrimOp -> Bool
-nopOp Int2WordOp     = True
-nopOp Word2IntOp     = True
-nopOp Int2AddrOp     = True
-nopOp Addr2IntOp     = True
-nopOp ChrOp          = True  -- Int# and Char# are rep'd the same
-nopOp OrdOp          = True
-nopOp _              = False
-
--- These PrimOps turn into double casts
-
-narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
-narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
-narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
-narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
-narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
-narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
-narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
-narrowOp _              = Nothing
-
--- Native word signless ops
-
-translateOp :: DynFlags -> PrimOp -> Maybe MachOp
-translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)
-translateOp dflags IntSubOp       = Just (mo_wordSub dflags)
-translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)
-translateOp dflags WordSubOp      = Just (mo_wordSub dflags)
-translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)
-translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)
-
-translateOp dflags IntEqOp        = Just (mo_wordEq dflags)
-translateOp dflags IntNeOp        = Just (mo_wordNe dflags)
-translateOp dflags WordEqOp       = Just (mo_wordEq dflags)
-translateOp dflags WordNeOp       = Just (mo_wordNe dflags)
-translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)
-translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)
-
-translateOp dflags AndOp          = Just (mo_wordAnd dflags)
-translateOp dflags OrOp           = Just (mo_wordOr dflags)
-translateOp dflags XorOp          = Just (mo_wordXor dflags)
-translateOp dflags NotOp          = Just (mo_wordNot dflags)
-translateOp dflags SllOp          = Just (mo_wordShl dflags)
-translateOp dflags SrlOp          = Just (mo_wordUShr dflags)
-
-translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)
-
--- Native word signed ops
-
-translateOp dflags IntMulOp        = Just (mo_wordMul dflags)
-translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))
-translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)
-translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)
-translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)
-
-
-translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)
-translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)
-translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)
-translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)
-
-translateOp dflags ISllOp         = Just (mo_wordShl dflags)
-translateOp dflags ISraOp         = Just (mo_wordSShr dflags)
-translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)
-
--- Native word unsigned ops
-
-translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)
-translateOp dflags WordLeOp       = Just (mo_wordULe dflags)
-translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)
-translateOp dflags WordLtOp       = Just (mo_wordULt dflags)
-
-translateOp dflags WordMulOp      = Just (mo_wordMul dflags)
-translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)
-translateOp dflags WordRemOp      = Just (mo_wordURem dflags)
-
-translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)
-translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)
-translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)
-translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)
-
--- Char# ops
-
-translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))
-translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))
-translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))
-translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))
-translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))
-translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))
-
--- Double ops
-
-translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)
-translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)
-translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)
-translateOp _      DoubleLeOp     = Just (MO_F_Le W64)
-translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)
-translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)
-
-translateOp _      DoubleAddOp    = Just (MO_F_Add W64)
-translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)
-translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)
-translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)
-translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)
-
--- Float ops
-
-translateOp _      FloatEqOp     = Just (MO_F_Eq W32)
-translateOp _      FloatNeOp     = Just (MO_F_Ne W32)
-translateOp _      FloatGeOp     = Just (MO_F_Ge W32)
-translateOp _      FloatLeOp     = Just (MO_F_Le W32)
-translateOp _      FloatGtOp     = Just (MO_F_Gt W32)
-translateOp _      FloatLtOp     = Just (MO_F_Lt W32)
-
-translateOp _      FloatAddOp    = Just (MO_F_Add  W32)
-translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)
-translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)
-translateOp _      FloatDivOp    = Just (MO_F_Quot W32)
-translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)
-
--- Conversions
-
-translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)
-translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))
-
-translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)
-translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))
-
-translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)
-translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)
-
--- Word comparisons masquerading as more exotic things.
-
-translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)
-translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)
-translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)
-translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
-translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
-translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)
-translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)
-
-translateOp _      _ = Nothing
-
--- These primops are implemented by CallishMachOps, because they sometimes
--- turn into foreign calls depending on the backend.
-
-callishOp :: PrimOp -> Maybe CallishMachOp
-callishOp DoublePowerOp  = Just MO_F64_Pwr
-callishOp DoubleSinOp    = Just MO_F64_Sin
-callishOp DoubleCosOp    = Just MO_F64_Cos
-callishOp DoubleTanOp    = Just MO_F64_Tan
-callishOp DoubleSinhOp   = Just MO_F64_Sinh
-callishOp DoubleCoshOp   = Just MO_F64_Cosh
-callishOp DoubleTanhOp   = Just MO_F64_Tanh
-callishOp DoubleAsinOp   = Just MO_F64_Asin
-callishOp DoubleAcosOp   = Just MO_F64_Acos
-callishOp DoubleAtanOp   = Just MO_F64_Atan
-callishOp DoubleLogOp    = Just MO_F64_Log
-callishOp DoubleExpOp    = Just MO_F64_Exp
-callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
-
-callishOp FloatPowerOp  = Just MO_F32_Pwr
-callishOp FloatSinOp    = Just MO_F32_Sin
-callishOp FloatCosOp    = Just MO_F32_Cos
-callishOp FloatTanOp    = Just MO_F32_Tan
-callishOp FloatSinhOp   = Just MO_F32_Sinh
-callishOp FloatCoshOp   = Just MO_F32_Cosh
-callishOp FloatTanhOp   = Just MO_F32_Tanh
-callishOp FloatAsinOp   = Just MO_F32_Asin
-callishOp FloatAcosOp   = Just MO_F32_Acos
-callishOp FloatAtanOp   = Just MO_F32_Atan
-callishOp FloatLogOp    = Just MO_F32_Log
-callishOp FloatExpOp    = Just MO_F32_Exp
-callishOp FloatSqrtOp   = Just MO_F32_Sqrt
-
-callishOp _ = Nothing
-
-------------------------------------------------------------------------------
--- Helpers for translating various minor variants of array indexing.
-
--- Bytearrays outside the heap; hence non-pointers
-doIndexOffAddrOp, doIndexByteArrayOp
-        :: Maybe MachOp -> CmmType
-        -> [LocalReg] -> [CmmExpr] -> Code
-doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
-doIndexOffAddrOp _ _ _ _
-   = panic "CgPrimOp: doIndexOffAddrOp"
-
-doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
-   = do dflags <- getDynFlags
-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx
-doIndexByteArrayOp _ _ _ _
-   = panic "CgPrimOp: doIndexByteArrayOp"
-
-doReadPtrArrayOp :: LocalReg -> CmmExpr -> CmmExpr -> Code
-doReadPtrArrayOp res addr idx
-   = do dflags <- getDynFlags
-        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx
-
-
-doWriteOffAddrOp, doWriteByteArrayOp
-        :: Maybe MachOp -> CmmType
-        -> [LocalReg] -> [CmmExpr] -> Code
-doWriteOffAddrOp maybe_pre_write_cast rep [] [addr,idx,val]
-   = mkBasicIndexedWrite 0 maybe_pre_write_cast rep addr idx val
-doWriteOffAddrOp _ _ _ _
-   = panic "CgPrimOp: doWriteOffAddrOp"
-
-doWriteByteArrayOp maybe_pre_write_cast rep [] [addr,idx,val]
-   = do dflags <- getDynFlags
-        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast rep addr idx val
-doWriteByteArrayOp _ _ _ _
-   = panic "CgPrimOp: doWriteByteArrayOp"
-
-doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> Code
-doWritePtrArrayOp addr idx val
-   = do dflags <- getDynFlags
-        mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing (bWord dflags) addr idx val
-        stmtC (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
-   -- the write barrier.  We must write a byte into the mark table:
-   -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
-        stmtC $ CmmStore (
-          cmmOffsetExpr dflags
-           (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
-                          (loadArrPtrsSize dflags addr))
-           (card dflags idx)
-          ) (CmmLit (CmmInt 1 W8))
-
-loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
- where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags
-
-mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
-                   -> LocalReg -> CmmExpr -> CmmExpr -> Code
-mkBasicIndexedRead off Nothing read_rep res base idx
-   = do dflags <- getDynFlags
-        stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx))
-mkBasicIndexedRead off (Just cast) read_rep res base idx
-   = do dflags <- getDynFlags
-        stmtC (CmmAssign (CmmLocal res) (CmmMachOp cast [
-                                cmmLoadIndexOffExpr dflags off read_rep base idx]))
-
-mkBasicIndexedWrite :: ByteOff -> Maybe MachOp -> CmmType
-                    -> CmmExpr -> CmmExpr -> CmmExpr -> Code
-mkBasicIndexedWrite off Nothing write_rep base idx val
-   = do dflags <- getDynFlags
-        stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) val)
-mkBasicIndexedWrite off (Just cast) write_rep base idx val
-   = do dflags <- getDynFlags
-        stmtC (CmmStore (cmmIndexOffExpr dflags off write_rep base idx) (CmmMachOp cast [val]))
-
--- ----------------------------------------------------------------------------
--- Misc utils
-
-cmmIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
-cmmIndexOffExpr dflags off rep base idx
-   = cmmIndexExpr dflags (typeWidth rep) (cmmOffsetB dflags base off) idx
-
-cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
-cmmLoadIndexOffExpr dflags off rep base idx
-   = CmmLoad (cmmIndexOffExpr dflags off rep base idx) rep
-
-setInfo :: CmmExpr -> CmmExpr -> CmmStmt
-setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
-
--- ----------------------------------------------------------------------------
--- Copying byte arrays
-
--- | Takes a source 'ByteArray#', an offset in the source array, a
--- destination 'MutableByteArray#', an offset into the destination
--- array, and the number of bytes to copy.  Copies the given number of
--- bytes from the source array to the destination array.
-doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                  -> StgLiveVars -> Code
-doCopyByteArrayOp = emitCopyByteArray copy
-  where
-    -- Copy data (we assume the arrays aren't overlapping since
-    -- they're of different types)
-    copy _src _dst dst_p src_p bytes live =
-        do dflags <- getDynFlags
-           emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live
-
--- | Takes a source 'MutableByteArray#', an offset in the source
--- array, a destination 'MutableByteArray#', an offset into the
--- destination array, and the number of bytes to copy.  Copies the
--- given number of bytes from the source array to the destination
--- array.
-doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                         -> StgLiveVars -> Code
-doCopyMutableByteArrayOp = emitCopyByteArray copy
-  where
-    -- The only time the memory might overlap is when the two arrays
-    -- we were provided are the same array!
-    -- TODO: Optimize branch for common case of no aliasing.
-    copy src dst dst_p src_p bytes live =
-        do dflags <- getDynFlags
-           emitIfThenElse (cmmEqWord dflags src dst)
-               (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live)
-               (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags 1)) live)
-
-emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                  -> StgLiveVars -> Code)
-                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                  -> StgLiveVars
-                  -> Code
-emitCopyByteArray copy src src_off dst dst_off n live = do
-    dflags <- getDynFlags
-    dst_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
-    src_p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
-    copy src dst dst_p src_p n live
-
--- ----------------------------------------------------------------------------
--- Setting byte arrays
-
--- | Takes a 'MutableByteArray#', an offset into the array, a length,
--- and a byte, and sets each of the selected bytes in the array to the
--- character.
-doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                 -> StgLiveVars -> Code
-doSetByteArrayOp ba off len c live
-    = do dflags <- getDynFlags
-         p <- assignTemp $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
-         emitMemsetCall p c len (CmmLit (mkIntCLit dflags 1)) live
-
--- ----------------------------------------------------------------------------
--- Copying pointer arrays
-
--- EZY: This code has an unusually high amount of assignTemp calls, seen
--- nowhere else in the code generator.  This is mostly because these
--- "primitive" ops result in a surprisingly large amount of code.  It
--- will likely be worthwhile to optimize what is emitted here, so that
--- our optimization passes don't waste time repeatedly optimizing the
--- same bits of code.
-
--- | Takes a source 'Array#', an offset in the source array, a
--- destination 'MutableArray#', an offset into the destination array,
--- and the number of elements to copy.  Copies the given number of
--- elements from the source array to the destination array.
-doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-              -> StgLiveVars -> Code
-doCopyArrayOp = emitCopyArray copy
-  where
-    -- Copy data (we assume the arrays aren't overlapping since
-    -- they're of different types)
-    copy _src _dst dst_p src_p bytes live =
-        do dflags <- getDynFlags
-           emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live
-
--- | Takes a source 'MutableArray#', an offset in the source array, a
--- destination 'MutableArray#', an offset into the destination array,
--- and the number of elements to copy.  Copies the given number of
--- elements from the source array to the destination array.
-doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                     -> StgLiveVars -> Code
-doCopyMutableArrayOp = emitCopyArray copy
-  where
-    -- The only time the memory might overlap is when the two arrays
-    -- we were provided are the same array!
-    -- TODO: Optimize branch for common case of no aliasing.
-    copy src dst dst_p src_p bytes live =
-        do dflags <- getDynFlags
-           emitIfThenElse (cmmEqWord dflags src dst)
-               (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live)
-               (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live)
-
-emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                  -> StgLiveVars -> Code)
-              -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-              -> StgLiveVars
-              -> Code
-emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
-    dflags <- getDynFlags
-    -- Assign the arguments to temporaries so the code generator can
-    -- calculate liveness for us.
-    n <- assignTemp_ n0
-    emitIf (cmmNeWord dflags n (CmmLit (mkIntCLit dflags 0))) $ do
-        src <- assignTemp_ src0
-        src_off <- assignTemp_ src_off0
-        dst <- assignTemp_ dst0
-        dst_off <- assignTemp_ dst_off0
-
-        -- Set the dirty bit in the header.
-        stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
-
-        dst_elems_p <- assignTemp $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
-        dst_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p dst_off
-        src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
-        bytes <- assignTemp $ cmmMulWord dflags n (CmmLit (mkIntCLit dflags (wORD_SIZE dflags)))
-
-        copy src dst dst_p src_p bytes live
-
-        -- The base address of the destination card table
-        dst_cards_p <- assignTemp $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
-
-        emitSetCards dst_off dst_cards_p n live
-
--- | Takes an info table label, a register to return the newly
--- allocated array in, a source array, an offset in the source array,
--- and the number of elements to copy.  Allocates a new array and
--- initializes it form the source array.
-emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
-               -> StgLiveVars -> Code
-emitCloneArray info_p res_r src0 src_off0 n0 live = do
-    dflags <- getDynFlags
-    let arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit dflags $ fixedHdrSize dflags +
-                                     (sIZEOF_StgMutArrPtrs_NoHdr dflags `div` wORD_SIZE dflags)
-        myCapability = cmmSubWord dflags (CmmReg baseReg)
-                                         (CmmLit (mkIntCLit dflags (oFFSET_Capability_r dflags)))
-    -- Assign the arguments to temporaries so the code generator can
-    -- calculate liveness for us.
-    src <- assignTemp_ src0
-    src_off <- assignTemp_ src_off0
-    n <- assignTemp_ n0
-
-    card_bytes <- assignTemp $ cardRoundUp dflags n
-    size <- assignTemp $ cmmAddWord dflags n (bytesToWordsRoundUp dflags card_bytes)
-    words <- assignTemp $ cmmAddWord dflags (arrPtrsHdrSizeW dflags) size
-
-    arr_r <- newTemp (bWord dflags)
-    emitAllocateCall arr_r myCapability words live
-    tickyAllocPrim (CmmLit (mkIntCLit dflags (arrPtrsHdrSize dflags))) (cmmMulWord dflags n (wordSize dflags))
-        (CmmLit $ mkIntCLit dflags 0)
-
-    let arr = CmmReg (CmmLocal arr_r)
-    emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCS
-    stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags +
-                                             oFFSET_StgMutArrPtrs_ptrs dflags)) n
-    stmtC $ CmmStore (cmmOffsetB dflags arr (fixedHdrSize dflags * wORD_SIZE dflags +
-                                             oFFSET_StgMutArrPtrs_size dflags)) size
-
-    dst_p <- assignTemp $ cmmOffsetB dflags arr (arrPtrsHdrSize dflags)
-    src_p <- assignTemp $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags))
-             src_off
-
-    emitMemcpyCall dst_p src_p (cmmMulWord dflags n (wordSize dflags))
-        (CmmLit (mkIntCLit dflags (wORD_SIZE dflags))) live
-
-    emitMemsetCall (cmmOffsetExprW dflags dst_p n)
-        (CmmLit (mkIntCLit dflags 1))
-        card_bytes
-        (CmmLit (mkIntCLit dflags (wORD_SIZE dflags)))
-        live
-    stmtC $ CmmAssign (CmmLocal res_r) arr
-
--- | Takes and offset in the destination array, the base address of
--- the card table, and the number of elements affected (*not* the
--- number of cards). The number of elements may not be zero.
--- Marks the relevant cards as dirty.
-emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
-emitSetCards dst_start dst_cards_start n live = do
-    dflags <- getDynFlags
-    start_card <- assignTemp $ card dflags dst_start
-    let end_card = card dflags (cmmAddWord dflags dst_start n)
-    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
-        (CmmLit (mkIntCLit dflags 1))
-        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (CmmLit (mkIntCLit dflags 1)))
-        (CmmLit (mkIntCLit dflags 1)) -- no alignment (1 byte)
-        live
-
--- Convert an element index to a card index
-card :: DynFlags -> CmmExpr -> CmmExpr
-card dflags i = cmmUShrWord dflags i (CmmLit (mkIntCLit dflags (mUT_ARR_PTRS_CARD_BITS dflags)))
-
--- Convert a number of elements to a number of cards, rounding up
-cardRoundUp :: DynFlags -> CmmExpr -> CmmExpr
-cardRoundUp dflags i = card dflags (cmmAddWord dflags i (CmmLit (mkIntCLit dflags ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))))
-
-bytesToWordsRoundUp :: DynFlags -> CmmExpr -> CmmExpr
-bytesToWordsRoundUp dflags e
-    = cmmQuotWord dflags
-          (cmmAddWord dflags e (CmmLit (mkIntCLit dflags (wORD_SIZE dflags - 1))))
-          (wordSize dflags)
-
-wordSize :: DynFlags -> CmmExpr
-wordSize dflags = CmmLit (mkIntCLit dflags (wORD_SIZE dflags))
-
--- | Emit a call to @memcpy@.
-emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
-               -> Code
-emitMemcpyCall dst src n align live = do
-    vols <- getVolatileRegs live
-    emitForeignCall' PlayRisky
-        [{-no results-}]
-        (CmmPrim MO_Memcpy Nothing)
-        [ (CmmHinted dst AddrHint)
-        , (CmmHinted src AddrHint)
-        , (CmmHinted n NoHint)
-        , (CmmHinted align NoHint)
-        ]
-        (Just vols)
-        NoC_SRT -- No SRT b/c we do PlayRisky
-        CmmMayReturn
-
--- | Emit a call to @memmove@.
-emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
-                -> Code
-emitMemmoveCall dst src n align live = do
-    vols <- getVolatileRegs live
-    emitForeignCall' PlayRisky
-        [{-no results-}]
-        (CmmPrim MO_Memmove Nothing)
-        [ (CmmHinted dst AddrHint)
-        , (CmmHinted src AddrHint)
-        , (CmmHinted n NoHint)
-        , (CmmHinted align NoHint)
-        ]
-        (Just vols)
-        NoC_SRT -- No SRT b/c we do PlayRisky
-        CmmMayReturn
-
--- | Emit a call to @memset@.  The second argument must be a word but
--- its value must fit inside an unsigned char.
-emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
-               -> Code
-emitMemsetCall dst c n align live = do
-    vols <- getVolatileRegs live
-    emitForeignCall' PlayRisky
-        [{-no results-}]
-        (CmmPrim MO_Memset Nothing)
-        [ (CmmHinted dst AddrHint)
-        , (CmmHinted c NoHint)
-        , (CmmHinted n NoHint)
-        , (CmmHinted align NoHint)
-        ]
-        (Just vols)
-        NoC_SRT -- No SRT b/c we do PlayRisky
-        CmmMayReturn
-
--- | Emit a call to @allocate@.
-emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
-emitAllocateCall res cap n live = do
-    vols <- getVolatileRegs live
-    emitForeignCall' PlayRisky
-        [CmmHinted res AddrHint]
-        (CmmCallee allocate CCallConv)
-        [ (CmmHinted cap AddrHint)
-        , (CmmHinted n NoHint)
-        ]
-        (Just vols)
-        NoC_SRT -- No SRT b/c we do PlayRisky
-        CmmMayReturn
-  where
-    allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
-                                 ForeignLabelInExternalPackage IsFunction))
-
-emitPopCntCall :: LocalReg -> CmmExpr -> Width -> StgLiveVars -> Code
-emitPopCntCall res x width live = do
-    vols <- getVolatileRegs live
-    emitForeignCall' PlayRisky
-        [CmmHinted res NoHint]
-        (CmmPrim (MO_PopCnt width) Nothing)
-        [(CmmHinted x NoHint)]
-        (Just vols)
-        NoC_SRT -- No SRT b/c we do PlayRisky
-        CmmMayReturn
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
deleted file mode 100644 (file)
index c7ed0d5..0000000
+++ /dev/null
@@ -1,310 +0,0 @@
------------------------------------------------------------------------------
---
--- Code generation for profiling
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module CgProf (
-        mkCCostCentre, mkCCostCentreStack,
-
-        -- Cost-centre Profiling
-        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
-        enterCostCentreThunk,
-        enterCostCentreFun,
-        costCentreFrom,
-        curCCS, storeCurCCS,
-        emitCostCentreDecl, emitCostCentreStackDecl,
-        emitSetCCC,
-
-        -- Lag/drag/void stuff
-        ldvEnter, ldvEnterClosure, ldvRecordCreate
-  ) where
-
-#include "HsVersions.h"
-
-import ClosureInfo
-import CgUtils
-import CgMonad
-import SMRep
-
-import OldCmm
-import OldCmmUtils
-import CLabel
-
-import qualified Module
-import CostCentre
-import DynFlags
-import FastString
-import Module
-import Outputable
-
-import Data.Char
-import Control.Monad
-
------------------------------------------------------------------------------
---
--- Cost-centre-stack Profiling
---
------------------------------------------------------------------------------
-
--- Expression representing the current cost centre stack
-curCCS :: CmmExpr
-curCCS = CmmReg (CmmGlobal CCCS)
-
-storeCurCCS :: CmmExpr -> CmmStmt
-storeCurCCS e = CmmAssign (CmmGlobal CCCS) e
-
-mkCCostCentre :: CostCentre -> CmmLit
-mkCCostCentre cc = CmmLabel (mkCCLabel cc)
-
-mkCCostCentreStack :: CostCentreStack -> CmmLit
-mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
-
-costCentreFrom :: DynFlags
-               -> CmmExpr       -- A closure pointer
-               -> CmmExpr       -- The cost centre from that closure
-costCentreFrom dflags cl
-    = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (bWord dflags)
-
-staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
--- The profiling header words in a static closure
--- Was SET_STATIC_PROF_HDR
-staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs,
-                                                staticLdvInit dflags]
-
-dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
--- Profiling header words in a dynamic closure
-dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
-
-initUpdFrameProf :: CmmExpr -> Code
--- Initialise the profiling field of an update frame
-initUpdFrameProf frame_amode
-  = ifProfiling $       -- frame->header.prof.ccs = CCCS
-    do dflags <- getDynFlags
-       stmtC (CmmStore (cmmOffsetB dflags frame_amode (oFFSET_StgHeader_ccs dflags)) curCCS)
-        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
-        -- is unnecessary because it is not used anyhow.
-
--- -----------------------------------------------------------------------------
--- Recording allocation in a cost centre
-
--- | Record the allocation of a closure.  The CmmExpr is the cost
--- centre stack to which to attribute the allocation.
-profDynAlloc :: ClosureInfo -> CmmExpr -> Code
-profDynAlloc cl_info ccs
-  = ifProfiling $
-    do dflags <- getDynFlags
-       profAlloc (mkIntExpr dflags (closureSize dflags cl_info)) ccs
-
--- | Record the allocation of a closure (size is given by a CmmExpr)
--- The size must be in words, because the allocation counter in a CCS counts
--- in words.
---
--- This API is used by the @CCS_ALLOC()@ macro in @.cmm@ code.
---
-profAlloc :: CmmExpr -> CmmExpr -> Code
-profAlloc words ccs
-  = ifProfiling $
-    do dflags <- getDynFlags
-       let alloc_rep = typeWidth (rEP_CostCentreStack_mem_alloc dflags)
-       stmtC (addToMemE alloc_rep
-                   (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
-                   (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $
-                     [CmmMachOp (mo_wordSub dflags) [words,
-                                                     mkIntExpr dflags (profHdrSize dflags)]]))
-                   -- subtract the "profiling overhead", which is the
-                   -- profiling header in a closure.
-
--- -----------------------------------------------------------------------
--- Setting the current cost centre on entry to a closure
-
-enterCostCentreThunk :: CmmExpr -> Code
-enterCostCentreThunk closure =
-  ifProfiling $ do
-    dflags <- getDynFlags
-    stmtC $ storeCurCCS (costCentreFrom dflags closure)
-
-enterCostCentreFun :: CostCentreStack -> CmmExpr -> [GlobalReg] -> Code
-enterCostCentreFun ccs closure vols =
-  ifProfiling $ do
-    if isCurrentCCS ccs
-       then do dflags <- getDynFlags
-               emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS")
-                   [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
-                    CmmHinted (costCentreFrom dflags closure) AddrHint] vols
-       else return () -- top-level function, nothing to do
-
-ifProfiling :: Code -> Code
-ifProfiling code
-    = do dflags <- getDynFlags
-         if gopt Opt_SccProfilingOn dflags then code else nopC
-
-ifProfilingL :: DynFlags -> [a] -> [a]
-ifProfilingL dflags xs
-  | gopt Opt_SccProfilingOn dflags = xs
-  | otherwise                      = []
-
--- ---------------------------------------------------------------------------
--- Initialising Cost Centres & CCSs
-
-emitCostCentreDecl
-   :: CostCentre
-   -> Code
-emitCostCentreDecl cc = do
-                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
-  { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
-  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS
-                                        $ Module.moduleName
-                                        $ cc_mod cc)
-                -- All cost centres will be in the main package, since we
-                -- don't normally use -auto-all or add SCCs to other packages.
-                -- Hence don't emit the package name in the module here.
-  ; dflags <- getDynFlags
-  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
-                   showPpr dflags (costCentreSrcSpan cc)
-           -- XXX going via FastString to get UTF-8 encoding is silly
-  ; let
-     is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
-            | otherwise  = zero dflags
-     lits = [ zero dflags,     -- StgInt ccID,
-              label,    -- char *label,
-              modl,     -- char *module,
-              loc,      -- char *srcloc,
-              zero64,   -- StgWord64 mem_alloc
-              zero dflags,     -- StgWord time_ticks
-              is_caf,   -- StgInt is_caf
-              zero dflags      -- struct _CostCentre *link
-            ]
-  ; emitDataLits (mkCCLabel cc) lits
-  }
-
-
-emitCostCentreStackDecl
-   :: CostCentreStack
-   -> Code
-emitCostCentreStackDecl ccs
-  | Just cc <- maybeSingletonCCS ccs = do
-  { dflags <- getDynFlags
-  ; let
-        -- Note: to avoid making any assumptions about how the
-        -- C compiler (that compiles the RTS, in particular) does
-        -- layouts of structs containing long-longs, simply
-        -- pad out the struct with zero words until we hit the
-        -- size of the overall struct (which we get via DerivedConstants.h)
-        --
-     lits = zero dflags
-          : mkCCostCentre cc
-          : replicate (sizeof_ccs_words dflags - 2) (zero dflags)
-  ; emitDataLits (mkCCSLabel ccs) lits
-  }
-  | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
-
-zero :: DynFlags -> CmmLit
-zero dflags = mkIntCLit dflags 0
-zero64 :: CmmLit
-zero64 = CmmInt 0 W64
-
-sizeof_ccs_words :: DynFlags -> Int
-sizeof_ccs_words dflags
-    -- round up to the next word.
-  | ms == 0   = ws
-  | otherwise = ws + 1
-  where
-   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
-
--- ---------------------------------------------------------------------------
--- Set the current cost centre stack
-
-emitSetCCC :: CostCentre -> Bool -> Bool -> Code
-emitSetCCC cc tick push
- = do dflags <- getDynFlags
-      if gopt Opt_SccProfilingOn dflags
-          then do tmp <- newTemp (bWord dflags) -- TODO FIXME NOW
-                  pushCostCentre tmp curCCS cc
-                  when tick $ stmtC (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
-                  when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp)))
-          else nopC
-
-pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
-pushCostCentre result ccs cc
-  = emitRtsCallWithResult result AddrHint
-        rtsPackageId
-        (fsLit "pushCostCentre") [CmmHinted ccs AddrHint,
-                                  CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
-
-bumpSccCount :: DynFlags -> CmmExpr -> CmmStmt
-bumpSccCount dflags ccs
-  = addToMem (typeWidth (rEP_CostCentreStack_scc_count dflags))
-         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
-
------------------------------------------------------------------------------
---
---              Lag/drag/void stuff
---
------------------------------------------------------------------------------
-
---
--- Initial value for the LDV field in a static closure
---
-staticLdvInit :: DynFlags -> CmmLit
-staticLdvInit = zeroCLit
-
---
--- Initial value of the LDV field in a dynamic closure
---
-dynLdvInit :: DynFlags -> CmmExpr
-dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
-  CmmMachOp (mo_wordOr dflags) [
-      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
-      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
-  ]
-
---
--- Initialise the LDV word of a new closure
---
-ldvRecordCreate :: CmmExpr -> Code
-ldvRecordCreate closure = do dflags <- getDynFlags
-                             stmtC $ CmmStore (ldvWord dflags closure) (dynLdvInit dflags)
-
---
--- Called when a closure is entered, marks the closure as having been "used".
--- The closure is not an 'inherently used' one.
--- The closure is not IND or IND_OLDGEN because neither is considered for LDV
--- profiling.
---
-ldvEnterClosure :: ClosureInfo -> Code
-ldvEnterClosure closure_info
-    = do dflags <- getDynFlags
-         let tag = funTag dflags closure_info
-         ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
-        -- don't forget to substract node's tag
-
-ldvEnter :: CmmExpr -> Code
--- Argument is a closure pointer
-ldvEnter cl_ptr = do
-  dflags <- getDynFlags
-  let
-        -- don't forget to substract node's tag
-    ldv_wd = ldvWord dflags cl_ptr
-    new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
-                                                     (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
-                 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
-  ifProfiling $
-     -- if (era > 0) {
-     --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
-     --                era | LDV_STATE_USE }
-    emitIf (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
-           (stmtC (CmmStore ldv_wd new_ldv_wd))
-
-loadEra :: DynFlags -> CmmExpr
-loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
-                           [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) (cInt dflags)]
-
-ldvWord :: DynFlags -> CmmExpr -> CmmExpr
--- Takes the address of a closure, and returns
--- the address of the LDV word in the closure
-ldvWord dflags closure_ptr
-    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
-
diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs
deleted file mode 100644 (file)
index 2f7bdfc..0000000
+++ /dev/null
@@ -1,371 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-\section[CgStackery]{Stack management functions}
-
-Stack-twiddling operations, which are pretty low-down and grimy.
-(This is the module that knows all about stack layouts, etc.)
-
-\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgStackery (
-       spRel, getVirtSp, getRealSp, setRealSp,
-       setRealAndVirtualSp, getSpRelOffset,
-
-       allocPrimStack, allocStackTop, deAllocStackTop,
-       adjustStackHW, getFinalStackHW, 
-       setStackFrame, getStackFrame,
-       mkVirtStkOffsets, mkStkAmodes,
-       freeStackSlots, 
-       pushUpdateFrame, pushBHUpdateFrame, emitPushUpdateFrame,
-    ) where
-
-#include "HsVersions.h"
-
-import CgMonad
-import CgUtils
-import CgProf
-import ClosureInfo( CgRep(..), cgRepSizeW )
-import SMRep
-import OldCmm
-import OldCmmUtils
-import CLabel
-import DynFlags
-import Util
-import OrdList
-import Outputable
-
-import Control.Monad
-import Data.List
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection[CgUsages-stackery]{Monad things for fiddling with stack usage}
-%*                                                                     *
-%************************************************************************
-
-spRel is a little function that abstracts the stack direction.  Note that most
-of the code generator is dependent on the stack direction anyway, so
-changing this on its own spells certain doom.  ToDo: remove?
-
-       THIS IS DIRECTION SENSITIVE!
-
-Stack grows down, positive virtual offsets correspond to negative
-additions to the stack pointer.
-
-\begin{code}
-spRel :: VirtualSpOffset       -- virtual offset of Sp
-      -> VirtualSpOffset       -- virtual offset of The Thing
-      -> WordOff               -- integer offset
-spRel sp off = sp - off
-\end{code}
-
-@setRealAndVirtualSp@ sets into the environment the offsets of the
-current position of the real and virtual stack pointers in the current
-stack frame.  The high-water mark is set too.  It generates no code.
-It is used to initialise things at the beginning of a closure body.
-
-\begin{code}
-setRealAndVirtualSp :: VirtualSpOffset         -- New real Sp
-                    -> Code
-
-setRealAndVirtualSp new_sp 
-  = do { stk_usg <- getStkUsage
-       ; setStkUsage (stk_usg {virtSp = new_sp, 
-                               realSp = new_sp, 
-                               hwSp   = new_sp}) }
-
-getVirtSp :: FCode VirtualSpOffset
-getVirtSp
-  = do { stk_usg <- getStkUsage
-       ; return (virtSp stk_usg) }
-
-getRealSp :: FCode VirtualSpOffset
-getRealSp
-  = do { stk_usg <- getStkUsage
-       ; return (realSp stk_usg) }
-
-setRealSp :: VirtualSpOffset -> Code
-setRealSp new_real_sp
-  = do { stk_usg <- getStkUsage
-       ; setStkUsage (stk_usg {realSp = new_real_sp}) }
-
-getSpRelOffset :: VirtualSpOffset -> FCode CmmExpr
-getSpRelOffset virtual_offset
-  = do dflags <- getDynFlags
-       real_sp <- getRealSp
-       return (cmmRegOffW dflags spReg (spRel real_sp virtual_offset))
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection[CgStackery-layout]{Laying out a stack frame}
-%*                                                                     *
-%************************************************************************
-
-'mkVirtStkOffsets' is given a list of arguments.  The first argument
-gets the /largest/ virtual stack offset (remember, virtual offsets
-increase towards the top of stack).
-
-\begin{code}
-mkVirtStkOffsets
-         :: DynFlags
-         -> VirtualSpOffset    -- Offset of the last allocated thing
-         -> [(CgRep,a)]                -- things to make offsets for
-         -> (VirtualSpOffset,          -- OUTPUTS: Topmost allocated word
-             [(a, VirtualSpOffset)])   -- things with offsets (voids filtered out)
-
-mkVirtStkOffsets dflags init_Sp_offset things
-    = loop init_Sp_offset [] (reverse things)
-  where
-    loop offset offs [] = (offset,offs)
-    loop offset offs ((VoidArg,_):things) = loop offset offs things
-       -- ignore Void arguments
-    loop offset offs ((rep,t):things)
-       = loop thing_slot ((t,thing_slot):offs) things
-       where
-         thing_slot = offset + cgRepSizeW dflags rep
-           -- offset of thing is offset+size, because we're 
-           -- growing the stack *downwards* as the offsets increase.
-
--- | 'mkStkAmodes' is a higher-level version of
--- 'mkVirtStkOffsets'.  It starts from the tail-call locations.
--- It returns a single list of addressing modes for the stack
--- locations, and therefore is in the monad.  It /doesn't/ adjust the
--- high water mark.
-
-mkStkAmodes 
-       :: VirtualSpOffset          -- Tail call positions
-       -> [(CgRep,CmmExpr)]        -- things to make offsets for
-       -> FCode (VirtualSpOffset,  -- OUTPUTS: Topmost allocated word
-                 CmmStmts)         -- Assignments to appropriate stk slots
-
-mkStkAmodes tail_Sp things
-  = do dflags <- getDynFlags
-       rSp <- getRealSp
-       let (last_Sp_offset, offsets) = mkVirtStkOffsets dflags tail_Sp things
-           abs_cs = [ CmmStore (cmmRegOffW dflags spReg (spRel rSp offset)) amode
-                    | (amode, offset) <- offsets
-                    ]
-       returnFC (last_Sp_offset, toOL abs_cs)
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection[CgStackery-monadery]{Inside-monad functions for stack manipulation}
-%*                                                                     *
-%************************************************************************
-
-Allocate a virtual offset for something.
-
-\begin{code}
-allocPrimStack :: CgRep -> FCode VirtualSpOffset
-allocPrimStack rep = do dflags <- getDynFlags
-                        allocPrimStack' dflags rep
-
-allocPrimStack' :: DynFlags -> CgRep -> FCode VirtualSpOffset
-allocPrimStack' dflags rep
-  = do { stk_usg <- getStkUsage
-       ; let free_stk = freeStk stk_usg
-       ; case find_block free_stk of
-            Nothing -> do 
-               { let push_virt_sp = virtSp stk_usg + size
-               ; setStkUsage (stk_usg { virtSp = push_virt_sp,
-                                        hwSp   = hwSp stk_usg `max` push_virt_sp })
-                                               -- Adjust high water mark
-               ; return push_virt_sp }
-            Just slot -> do
-               { setStkUsage (stk_usg { freeStk = delete_block free_stk slot }) 
-               ; return slot }
-       }
-  where
-    size :: WordOff
-    size = cgRepSizeW dflags rep
-
-       -- Find_block looks for a contiguous chunk of free slots
-       -- returning the offset of its topmost word
-    find_block :: [VirtualSpOffset] -> Maybe VirtualSpOffset
-    find_block [] = Nothing
-    find_block (slot:slots)
-       | take size (slot:slots) == [slot..top_slot]
-       = Just top_slot
-       | otherwise
-       = find_block slots
-       where   -- The stack grows downwards, with increasing virtual offsets.
-               -- Therefore, the address of a multi-word object is the *highest*
-               -- virtual offset it occupies (top_slot below).
-           top_slot = slot+size-1
-
-    delete_block free_stk slot = [ s | s <- free_stk, 
-                                      (s<=slot-size) || (s>slot) ]
-                     -- Retain slots which are not in the range
-                     -- slot-size+1..slot
-\end{code}
-
-Allocate a chunk ON TOP OF the stack.  
-
-\begin{code}
-allocStackTop :: WordOff -> FCode ()
-allocStackTop size
-  = do { stk_usg <- getStkUsage
-       ; let push_virt_sp = virtSp stk_usg + size
-       ; setStkUsage (stk_usg { virtSp = push_virt_sp,
-                                hwSp   = hwSp stk_usg `max` push_virt_sp }) }
-\end{code}
-
-Pop some words from the current top of stack.  This is used for
-de-allocating the return address in a case alternative.
-
-\begin{code}
-deAllocStackTop :: WordOff -> FCode ()
-deAllocStackTop size
-  = do { stk_usg <- getStkUsage
-       ; let pop_virt_sp = virtSp stk_usg - size
-       ; setStkUsage (stk_usg { virtSp = pop_virt_sp }) }
-\end{code}
-
-\begin{code}
-adjustStackHW :: VirtualSpOffset -> Code
-adjustStackHW offset
-  = do { stk_usg <- getStkUsage
-       ; setStkUsage (stk_usg { hwSp = hwSp stk_usg `max` offset }) }
-\end{code}
-
-A knot-tying beast.
-
-\begin{code}
-getFinalStackHW :: (VirtualSpOffset -> Code) -> Code
-getFinalStackHW fcode
-  = do { fixC_ (\hw_sp -> do
-               { fcode hw_sp
-               ; stk_usg <- getStkUsage
-               ; return (hwSp stk_usg) })
-       ; return () }
-\end{code}
-
-\begin{code}
-setStackFrame :: VirtualSpOffset -> Code
-setStackFrame offset
-  = do { stk_usg <- getStkUsage
-       ; setStkUsage (stk_usg { frameSp = offset }) }
-
-getStackFrame :: FCode VirtualSpOffset
-getStackFrame
-  = do { stk_usg <- getStkUsage
-       ; return (frameSp stk_usg) }
-\end{code}
-
-
-%********************************************************
-%*                                                     *
-%*             Setting up update frames                *
-%*                                                     *
-%********************************************************
-
-@pushUpdateFrame@ $updatee$ pushes a general update frame which
-points to $updatee$ as the thing to be updated.  It is only used
-when a thunk has just been entered, so the (real) stack pointers
-are guaranteed to be nicely aligned with the top of stack.
-@pushUpdateFrame@ adjusts the virtual and tail stack pointers
-to reflect the frame pushed.
-
-\begin{code}
-pushUpdateFrame :: CmmExpr -> Code -> Code
-pushUpdateFrame updatee code
-  = pushSpecUpdateFrame mkUpdInfoLabel updatee code
-
-pushBHUpdateFrame :: CmmExpr -> Code -> Code
-pushBHUpdateFrame updatee code
-  = pushSpecUpdateFrame mkBHUpdInfoLabel updatee code
-
-pushSpecUpdateFrame :: CLabel -> CmmExpr -> Code -> Code
-pushSpecUpdateFrame lbl updatee code
-  = do {
-      when debugIsOn $ do
-       { EndOfBlockInfo _ sequel <- getEndOfBlockInfo ;
-       ; MASSERT(case sequel of { OnStack -> True; _ -> False}) }
-       ; dflags <- getDynFlags
-       ; allocStackTop (fixedHdrSize dflags + 
-                          sIZEOF_StgUpdateFrame_NoHdr dflags `quot` wORD_SIZE dflags)
-       ; vsp <- getVirtSp
-       ; setStackFrame vsp
-       ; frame_addr <- getSpRelOffset vsp
-               -- The location of the lowest-address
-               -- word of the update frame itself
-
-                -- NB. we used to set the Sequel to 'UpdateCode' so
-                -- that we could jump directly to the update code if
-                -- we know that the next frame on the stack is an
-                -- update frame.  However, the RTS can sometimes
-                -- change an update frame into something else (see
-                -- e.g. Note [upd-black-hole] in rts/sm/Scav.c), so we
-                -- no longer make this assumption.
-       ; setEndOfBlockInfo (EndOfBlockInfo vsp OnStack) $
-           do  { emitSpecPushUpdateFrame lbl frame_addr updatee
-               ; code }
-       }
-
-emitPushUpdateFrame :: CmmExpr -> CmmExpr -> Code
-emitPushUpdateFrame = emitSpecPushUpdateFrame mkUpdInfoLabel
-
-emitSpecPushUpdateFrame :: CLabel -> CmmExpr -> CmmExpr -> Code
-emitSpecPushUpdateFrame lbl frame_addr updatee = do
-       dflags <- getDynFlags
-       stmtsC [  -- Set the info word
-                 CmmStore frame_addr (mkLblExpr lbl)
-               , -- And the updatee
-                 CmmStore (cmmOffsetB dflags frame_addr (off_updatee dflags)) updatee ]
-       initUpdFrameProf frame_addr
-
-off_updatee :: DynFlags -> ByteOff
-off_updatee dflags
-    = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgUpdateFrame_updatee dflags
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection[CgStackery-free]{Free stack slots}
-%*                                                                     *
-%************************************************************************
-
-Explicitly free some stack space.
-
-\begin{code}
-freeStackSlots :: [VirtualSpOffset] -> Code
-freeStackSlots extra_free
-  = do { stk_usg <- getStkUsage
-       ; let all_free = addFreeSlots (freeStk stk_usg) (sort extra_free)
-       ; let (new_vsp, new_free) = trim (virtSp stk_usg) all_free
-       ; setStkUsage (stk_usg { virtSp = new_vsp, freeStk = new_free }) }
-
-addFreeSlots :: [VirtualSpOffset] -> [VirtualSpOffset] -> [VirtualSpOffset]
--- Merge the two, assuming both are in increasing order
-addFreeSlots cs [] = cs
-addFreeSlots [] ns = ns
-addFreeSlots (c:cs) (n:ns)
-  | c < n     = c : addFreeSlots cs (n:ns)
-  | otherwise = n : addFreeSlots (c:cs) ns
-
-trim :: VirtualSpOffset -> [VirtualSpOffset] -> (VirtualSpOffset, [VirtualSpOffset])
--- Try to trim back the virtual stack pointer, where there is a
--- continuous bunch of free slots at the end of the free list
-trim vsp [] = (vsp, [])
-trim vsp (slot:slots)
-  = case trim vsp slots of
-      (vsp', []) 
-       | vsp' < slot  -> pprTrace "trim: strange" (ppr vsp <+> ppr (slot:slots))
-                         (vsp',   [])
-       | vsp' == slot -> (vsp'-1, [])
-       | otherwise    -> (vsp',   [slot])
-      (vsp', slots')   -> (vsp',   slot:slots')
-\end{code}
diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs
deleted file mode 100644 (file)
index b78415f..0000000
+++ /dev/null
@@ -1,509 +0,0 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-% Code generation for tail calls.
-
-\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgTailCall (
-       cgTailCall, performTailCall,
-       performReturn, performPrimReturn,
-       returnUnboxedTuple, ccallReturnUnboxedTuple,
-       pushUnboxedTuple,
-       tailCallPrimOp,
-        tailCallPrimCall,
-
-       pushReturnAddress
-    ) where
-
-#include "HsVersions.h"
-
-import CgMonad
-import CgBindery
-import CgInfoTbls
-import CgCallConv
-import CgStackery
-import CgHeapery
-import CgUtils
-import CgTicky
-import ClosureInfo
-import OldCmm  
-import OldCmmUtils
-import CLabel
-import Type
-import Id
-import StgSyn
-import PrimOp
-import DynFlags
-import Outputable
-import Util
-
-import Control.Monad
-import Data.Maybe
-
------------------------------------------------------------------------------
--- Tail Calls
-
-cgTailCall :: Id -> [StgArg] -> Code
-
--- Here's the code we generate for a tail call.  (NB there may be no
--- arguments, in which case this boils down to just entering a variable.)
--- 
---    *        Put args in the top locations of the stack.
---    *        Adjust the stack ptr
---    *        Make R1 point to the function closure if necessary.
---    *        Perform the call.
---
--- Things to be careful about:
---
---    *        Don't overwrite stack locations before you have finished with
---     them (remember you need the function and the as-yet-unmoved
---     arguments).
---    *        Preferably, generate no code to replace x by x on the stack (a
---     common situation in tail-recursion).
---    *        Adjust the stack high water mark appropriately.
--- 
--- Treat unboxed locals exactly like literals (above) except use the addr
--- mode for the local instead of (CLit lit) in the assignment.
-
-cgTailCall fun args
-  = do { fun_info <- getCgIdInfo fun
-
-       ; if isUnLiftedType (idType fun)
-         then  -- Primitive return
-               ASSERT( null args )
-           do  { fun_amode <- idInfoToAmode fun_info
-               ; performPrimReturn (cgIdInfoArgRep fun_info) fun_amode } 
-
-         else -- Normal case, fun is boxed
-           do  { arg_amodes <- getArgAmodes args
-               ; performTailCall fun_info arg_amodes noStmts }
-       }
-               
-
--- -----------------------------------------------------------------------------
--- The guts of a tail-call
-
-performTailCall 
-       :: CgIdInfo             -- The function
-       -> [(CgRep,CmmExpr)]    -- Args
-       -> CmmStmts             -- Pending simultaneous assignments
-                               --  *** GUARANTEED to contain only stack assignments.
-       -> Code
-
-performTailCall fun_info arg_amodes pending_assts
-  | Just join_sp <- maybeLetNoEscape fun_info
-  =       -- A let-no-escape is slightly different, because we
-          -- arrange the stack arguments into pointers and non-pointers
-          -- to make the heap check easier.  The tail-call sequence
-          -- is very similar to returning an unboxed tuple, so we
-          -- share some code.
-     do        { dflags <- getDynFlags
-        ; (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes
-       ; emitSimultaneously (pending_assts `plusStmts` arg_assts)
-       ; let lbl = enterReturnPtLabel dflags (idUnique (cgIdInfoId fun_info))
-       ; doFinalJump final_sp True $ jumpToLbl lbl (Just live) }
-
-  | otherwise
-  = do         { fun_amode <- idInfoToAmode fun_info
-       ; dflags <- getDynFlags
-       ; let assignSt  = CmmAssign nodeReg fun_amode
-              node_asst = oneStmt assignSt
-              node_live = Just [node]
-             (opt_node_asst, opt_node_live)
-                      | nodeMustPointToIt dflags lf_info = (node_asst, node_live)
-                      | otherwise                 = (noStmts, Just [])
-       ; EndOfBlockInfo sp _ <- getEndOfBlockInfo
-
-       ; case (getCallMethod dflags fun_name fun_has_cafs lf_info (length arg_amodes)) of
-
-           -- Node must always point to things we enter
-           EnterIt -> do
-               { emitSimultaneously (node_asst `plusStmts` pending_assts) 
-               ; let target       = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))
-                      enterClosure = stmtC (CmmJump target node_live)
-                      -- If this is a scrutinee
-                      -- let's check if the closure is a constructor
-                      -- so we can directly jump to the alternatives switch
-                      -- statement.
-                      jumpInstr = getEndOfBlockInfo >>=
-                                  maybeSwitchOnCons dflags enterClosure
-               ; doFinalJump sp False jumpInstr }
-    
-           -- A function, but we have zero arguments.  It is already in WHNF,
-           -- so we can just return it.  
-           -- As with any return, Node must point to it.
-           ReturnIt -> do
-               { emitSimultaneously (node_asst `plusStmts` pending_assts)
-               ; doFinalJump sp False $ emitReturnInstr node_live }
-    
-           -- A real constructor.  Don't bother entering it, 
-           -- just do the right sort of return instead.
-           -- As with any return, Node must point to it.
-           ReturnCon _ -> do
-               { emitSimultaneously (node_asst `plusStmts` pending_assts)
-               ; doFinalJump sp False $ emitReturnInstr node_live }
-
-           JumpToIt lbl -> do
-               { emitSimultaneously (opt_node_asst `plusStmts` pending_assts)
-               ; doFinalJump sp False $ jumpToLbl lbl opt_node_live }
-    
-           -- A slow function call via the RTS apply routines
-           -- Node must definitely point to the thing
-           SlowCall -> do 
-               {  when (not (null arg_amodes)) $ do
-                  { if (isKnownFun lf_info) 
-                       then tickyKnownCallTooFewArgs
-                       else tickyUnknownCall
-                  ; tickySlowCallPat (map fst arg_amodes) 
-                  }
-
-               ; let (apply_lbl, args, extra_args) 
-                       = constructSlowCall arg_amodes
-
-               ; directCall sp apply_lbl args extra_args node_live
-                       (node_asst `plusStmts` pending_assts)
-
-               }
-    
-           -- A direct function call (possibly with some left-over arguments)
-           DirectEntry lbl arity -> do
-               { if arity == length arg_amodes
-                       then tickyKnownCallExact
-                       else do tickyKnownCallExtraArgs
-                               tickySlowCallPat (map fst (drop arity arg_amodes))
-
-               ; let
-                    -- The args beyond the arity go straight on the stack
-                    (arity_args, extra_args) = splitAt arity arg_amodes
-     
-               ; directCall sp lbl arity_args extra_args opt_node_live
-                       (opt_node_asst `plusStmts` pending_assts)
-               }
-       }
-  where
-    fun_id    = cgIdInfoId fun_info
-    fun_name  = idName fun_id
-    lf_info   = cgIdInfoLF fun_info
-    fun_has_cafs = idCafInfo fun_id
-    untag_node dflags = CmmAssign nodeReg (cmmUntag dflags (CmmReg nodeReg))
-    -- Test if closure is a constructor
-    maybeSwitchOnCons dflags enterClosure eob
-              | EndOfBlockInfo _ (CaseAlts lbl _ _) <- eob,
-                not (gopt Opt_SccProfilingOn dflags)
-                -- we can't shortcut when profiling is on, because we have
-                -- to enter a closure to mark it as "used" for LDV profiling
-              = do { is_constr <- newLabelC
-                   -- Is the pointer tagged?
-                   -- Yes, jump to switch statement
-                   ; stmtC (CmmCondBranch (cmmIsTagged dflags (CmmReg nodeReg)) 
-                                is_constr)
-                   -- No, enter the closure.
-                   ; enterClosure
-                   ; labelC is_constr
-                   ; stmtC (CmmJump (entryCode dflags $
-                               CmmLit (CmmLabel lbl)) (Just [node]))
-                   }
-{-
-              -- This is a scrutinee for a case expression
-              -- so let's see if we can directly inspect the closure
-              | EndOfBlockInfo _ (CaseAlts lbl _ _ _) <- eob
-              = do { no_cons <- newLabelC
-                   -- Both the NCG and gcc optimize away the temp
-                   ; z <- newTemp  wordRep
-                   ; stmtC (CmmAssign z tag_expr)
-                   ; let tag = CmmReg z
-                   -- Is the closure a cons?
-                   ; stmtC (CmmCondBranch (cond1 tag) no_cons)
-                   ; stmtC (CmmCondBranch (cond2 tag) no_cons)
-                   -- Yes, jump to switch statement
-                   ; stmtC (CmmJump (CmmLit (CmmLabel lbl)))
-                   ; labelC no_cons
-                   -- No, enter the closure.
-                   ; enterClosure
-                   }
--}
-              -- No case expression involved, enter the closure.
-              | otherwise
-              = do { stmtC $ untag_node dflags
-                   ; enterClosure
-                   }
-        where
-          --cond1 tag  = cmmULtWord tag lowCons
-          -- More efficient than the above?
-{-
-          tag_expr   = cmmGetClosureType (CmmReg nodeReg)
-          cond1 tag  = cmmEqWord tag (CmmLit (mkIntCLit 0))
-          cond2 tag  = cmmUGtWord tag highCons
-          lowCons    = CmmLit (mkIntCLit 1)
-            -- CONSTR
-          highCons   = CmmLit (mkIntCLit 8)
-            -- CONSTR_NOCAF_STATIC (from ClosureType.h)
--}
-
-directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)]
-           -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts
-           -> Code
-directCall sp lbl args extra_args live_node assts = do
-  dflags <- getDynFlags
-  let
-       -- First chunk of args go in registers
-       (reg_arg_amodes, stk_args) = assignCallRegs dflags args
-     
-       -- Any "extra" arguments are placed in frames on the
-       -- stack after the other arguments.
-       slow_stk_args = slowArgs dflags extra_args
-
-       reg_assts = assignToRegs reg_arg_amodes
-        live_args = map snd reg_arg_amodes
-        live_regs = Just $ (fromMaybe [] live_node) ++ live_args
-  --
-  (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args)
-  emitSimultaneously $ reg_assts `plusStmts` stk_assts `plusStmts` assts
-  doFinalJump final_sp False $ jumpToLbl lbl live_regs
-
--- -----------------------------------------------------------------------------
--- The final clean-up before we do a jump at the end of a basic block.
--- This code is shared by tail-calls and returns.
-
-doFinalJump :: VirtualSpOffset -> Bool -> Code -> Code 
-doFinalJump final_sp is_let_no_escape jump_code
-  = do { -- Adjust the high-water mark if necessary
-         adjustStackHW final_sp
-
-       -- Push a return address if necessary (after the assignments
-       -- above, in case we clobber a live stack location)
-       --
-       -- DONT push the return address when we're about to jump to a
-       -- let-no-escape: the final tail call in the let-no-escape
-       -- will do this.
-       ; eob <- getEndOfBlockInfo
-       ; whenC (not is_let_no_escape) (pushReturnAddress eob)
-
-           -- Final adjustment of Sp/Hp
-       ; adjustSpAndHp final_sp
-
-           -- and do the jump
-       ; jump_code }
-
--- ----------------------------------------------------------------------------
--- A general return (just a special case of doFinalJump, above)
-
-performReturn :: Code  -- The code to execute to actually do the return
-             -> Code
-
-performReturn finish_code
-  = do  { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo
-       ; doFinalJump args_sp False finish_code }
-
--- ----------------------------------------------------------------------------
--- Primitive Returns
--- Just load the return value into the right register, and return.
-
-performPrimReturn :: CgRep -> CmmExpr -> Code
-
--- non-void return value
-performPrimReturn rep amode | not (isVoidArg rep)
-  = do { stmtC (CmmAssign ret_reg amode)
-       ; performReturn $ emitReturnInstr live_regs }
-  where
-    -- careful here as 'dataReturnConvPrim' will panic if given a Void rep
-    ret_reg@(CmmGlobal r) = dataReturnConvPrim rep
-    live_regs = Just [r]
-
--- void return value
-performPrimReturn _ _
-  = performReturn $ emitReturnInstr (Just [])
-
-
--- ---------------------------------------------------------------------------
--- Unboxed tuple returns
-
--- These are a bit like a normal tail call, except that:
---
---   - The tail-call target is an info table on the stack
---
---   - We separate stack arguments into pointers and non-pointers,
---     to make it easier to leave things in a sane state for a heap check.
---     This is OK because we can never partially-apply an unboxed tuple,
---     unlike a function.  The same technique is used when calling
---     let-no-escape functions, because they also can't be partially
---     applied.
-
-returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code
-returnUnboxedTuple amodes
-  = do         { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo
-       ; tickyUnboxedTupleReturn (length amodes)
-       ; (final_sp, assts, live_regs) <- pushUnboxedTuple args_sp amodes
-       ; emitSimultaneously assts
-       ; doFinalJump final_sp False $ emitReturnInstr (Just live_regs) }
-
-pushUnboxedTuple :: VirtualSpOffset            -- Sp at which to start pushing
-                -> [(CgRep, CmmExpr)]          -- amodes of the components
-                -> FCode (VirtualSpOffset,     -- final Sp
-                          CmmStmts,            -- assignments (regs+stack)
-                           [GlobalReg])         -- registers used (liveness)
-
-pushUnboxedTuple sp [] 
-  = return (sp, noStmts, [])
-pushUnboxedTuple sp amodes
-  = do { dflags <- getDynFlags
-        ; let  (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs dflags amodes
-                live_regs = map snd reg_arg_amodes
-       
-               -- separate the rest of the args into pointers and non-pointers
-               (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes
-               reg_arg_assts = assignToRegs reg_arg_amodes
-               
-           -- push ptrs, then nonptrs, on the stack
-       ; (ptr_sp,   ptr_assts)  <- mkStkAmodes sp ptr_args
-       ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args
-
-       ; returnFC (final_sp,
-                   reg_arg_assts `plusStmts` ptr_assts `plusStmts` nptr_assts,
-                    live_regs) }
-    
-                 
--- -----------------------------------------------------------------------------
--- Returning unboxed tuples.  This is mainly to support _ccall_GC_, where
--- we want to do things in a slightly different order to normal:
--- 
---             - push return address
---             - adjust stack pointer
---             - r = call(args...)
---             - assign regs for unboxed tuple (usually just R1 = r)
---             - return to continuation
--- 
--- The return address (i.e. stack frame) must be on the stack before
--- doing the call in case the call ends up in the garbage collector.
--- 
--- Sadly, the information about the continuation is lost after we push it
--- (in order to avoid pushing it again), so we end up doing a needless
--- indirect jump (ToDo).
-
-ccallReturnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code -> Code
-ccallReturnUnboxedTuple amodes before_jump
-  = do         { eob@(EndOfBlockInfo args_sp _) <- getEndOfBlockInfo
-
-       -- Push a return address if necessary
-       ; pushReturnAddress eob
-       ; setEndOfBlockInfo (EndOfBlockInfo args_sp OnStack)
-           (do { adjustSpAndHp args_sp
-               ; before_jump
-               ; returnUnboxedTuple amodes })
-    }
-
--- -----------------------------------------------------------------------------
--- Calling an out-of-line primop
-
-tailCallPrimOp :: PrimOp -> [StgArg] -> Code
-tailCallPrimOp op
- = tailCallPrim (mkRtsPrimOpLabel op)
-
-tailCallPrimCall :: PrimCall -> [StgArg] -> Code
-tailCallPrimCall primcall
- = tailCallPrim (mkPrimCallLabel primcall)
-
-tailCallPrim :: CLabel -> [StgArg] -> Code
-tailCallPrim lbl args
- = do { dflags <- getDynFlags
-        -- We're going to perform a normal-looking tail call, 
-               -- except that *all* the arguments will be in registers.
-               -- Hence the ASSERT( null leftovers )
-       ; arg_amodes <- getArgAmodes args
-       ; let (arg_regs, leftovers) = assignPrimOpCallRegs dflags arg_amodes
-              live_regs = Just $ map snd arg_regs
-             jump_to_primop = jumpToLbl lbl live_regs
-
-       ; ASSERT(null leftovers) -- no stack-resident args
-         emitSimultaneously (assignToRegs arg_regs)
-
-       ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo
-       ; doFinalJump args_sp False jump_to_primop }
-
--- -----------------------------------------------------------------------------
--- Return Addresses
-
--- We always push the return address just before performing a tail call
--- or return.  The reason we leave it until then is because the stack
--- slot that the return address is to go into might contain something
--- useful.
--- 
--- If the end of block info is 'CaseAlts', then we're in the scrutinee of a
--- case expression and the return address is still to be pushed.
--- 
--- There are cases where it doesn't look necessary to push the return
--- address: for example, just before doing a return to a known
--- continuation.  However, the continuation will expect to find the
--- return address on the stack in case it needs to do a heap check.
-
-pushReturnAddress :: EndOfBlockInfo -> Code
-
-pushReturnAddress (EndOfBlockInfo args_sp (CaseAlts lbl _ _))
-  = do { sp_rel <- getSpRelOffset args_sp
-       ; stmtC (CmmStore sp_rel (mkLblExpr lbl)) }
-
-pushReturnAddress _ = nopC
-
--- -----------------------------------------------------------------------------
--- Misc.
-
--- Passes no argument to the destination procedure
-jumpToLbl :: CLabel -> Maybe [GlobalReg] -> Code
-jumpToLbl lbl live = stmtC $ CmmJump (CmmLit $ CmmLabel lbl) live
-
-assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts
-assignToRegs reg_args 
-  = mkStmts [ CmmAssign (CmmGlobal reg_id) expr
-           | (expr, reg_id) <- reg_args ] 
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection[CgStackery-adjust]{Adjusting the stack pointers}
-%*                                                                     *
-%************************************************************************
-
-This function adjusts the stack and heap pointers just before a tail
-call or return.  The stack pointer is adjusted to its final position
-(i.e. to point to the last argument for a tail call, or the activation
-record for a return).  The heap pointer may be moved backwards, in
-cases where we overallocated at the beginning of the basic block (see
-CgCase.lhs for discussion).
-
-These functions {\em do not} deal with high-water-mark adjustment.
-That's done by functions which allocate stack space.
-
-\begin{code}
-adjustSpAndHp :: VirtualSpOffset       -- New offset for Arg stack ptr
-             -> Code
-adjustSpAndHp newRealSp 
-  = do { -- Adjust stack, if necessary.
-         -- NB: the conditional on the monad-carried realSp
-         --     is out of line (via codeOnly), to avoid a black hole
-       ; new_sp <- getSpRelOffset newRealSp
-       ; checkedAbsC (CmmAssign spReg new_sp)  -- Will generate no code in the case
-       ; setRealSp newRealSp                   -- where realSp==newRealSp
-
-         -- Adjust heap.  The virtual heap pointer may be less than the real Hp
-         -- because the latter was advanced to deal with the worst-case branch
-         -- of the code, and we may be in a better-case branch.  In that case,
-         -- move the real Hp *back* and retract some ticky allocation count.
-       ; hp_usg <- getHpUsage
-       ; let rHp = realHp hp_usg
-             vHp = virtHp hp_usg
-       ; new_hp <- getHpRelOffset vHp
-       ; checkedAbsC (CmmAssign hpReg new_hp)  -- Generates nothing when vHp==rHp
-       ; tickyAllocHeap (vHp - rHp)            -- ...ditto
-       ; setRealHp vHp
-       }
-\end{code}
-
diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs
deleted file mode 100644 (file)
index 898d3f0..0000000
+++ /dev/null
@@