diff options
| author | Simon Marlow <marlowsd@gmail.com> | 2012-10-14 13:03:32 +0100 |
|---|---|---|
| committer | Simon Marlow <marlowsd@gmail.com> | 2012-10-19 12:03:16 +0100 |
| commit | 6fbd46b0bb3ee56160b8216cb2a3bb718ccb41c2 (patch) | |
| tree | 8e8c569d0989f89c66a6ccd0d59a466266130649 | |
| parent | 53810006bbcd3fc9b58893858f95c3432cb33f0e (diff) | |
| download | haskell-6fbd46b0bb3ee56160b8216cb2a3bb718ccb41c2.tar.gz | |
Remove the old codegen
Except for CgUtils.fixStgRegisters that is used in the NCG and LLVM
backends, and should probably be moved somewhere else.
36 files changed, 114 insertions, 10606 deletions
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 46d1d72b0c..c483502cd9 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -179,7 +179,7 @@ import StgCmmUtils import StgCmmForeign import StgCmmExpr import StgCmmClosure -import StgCmmLayout +import StgCmmLayout hiding (ArgRep(..)) import StgCmmTicky import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame ) diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 3d0599b7ea..cf05db92b8 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -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]' diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index f39af7ce55..5f6f33ee8a 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -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 index 834276bd7b..0000000000 --- a/compiler/codeGen/CgBindery.lhs +++ /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 index e504a6a9ba..0000000000 --- a/compiler/codeGen/CgBindery.lhs-boot +++ /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 index e4095fd027..0000000000 --- a/compiler/codeGen/CgCallConv.hs +++ /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 index 595a30e7a1..0000000000 --- a/compiler/codeGen/CgCase.lhs +++ /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 index b5ce231856..0000000000 --- a/compiler/codeGen/CgClosure.lhs +++ /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 index abb280ff11..0000000000 --- a/compiler/codeGen/CgCon.lhs +++ /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 index 70fb600901..0000000000 --- a/compiler/codeGen/CgExpr.lhs +++ /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 index 29cdc3a605..0000000000 --- a/compiler/codeGen/CgExpr.lhs-boot +++ /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 index b0e6516f2d..0000000000 --- a/compiler/codeGen/CgForeignCall.hs +++ /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 index 8cff77381d..0000000000 --- a/compiler/codeGen/CgHeapery.lhs +++ /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 index 407de7b647..0000000000 --- a/compiler/codeGen/CgHpc.hs +++ /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 index be16bf6adf..0000000000 --- a/compiler/codeGen/CgInfoTbls.hs +++ /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 index 610869ad89..0000000000 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ /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 index f776af3b3b..0000000000 --- a/compiler/codeGen/CgMonad.lhs +++ /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 index 0e642cba59..0000000000 --- a/compiler/codeGen/CgParallel.hs +++ /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 index 6185a2b07f..0000000000 --- a/compiler/codeGen/CgPrimOp.hs +++ /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 index c7ed0d50c3..0000000000 --- a/compiler/codeGen/CgProf.hs +++ /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 index 2f7bdfc083..0000000000 --- a/compiler/codeGen/CgStackery.lhs +++ /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 index b78415fffa..0000000000 --- a/compiler/codeGen/CgTailCall.lhs +++ /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 index 898d3f0786..0000000000 --- a/compiler/codeGen/CgTicky.hs +++ /dev/null @@ -1,397 +0,0 @@ ------------------------------------------------------------------------------ --- --- Code generation for ticky-ticky profiling --- --- (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 CgTicky ( - emitTickyCounter, - - tickyDynAlloc, - tickyAllocHeap, - tickyAllocPrim, - tickyAllocThunk, - tickyAllocPAP, - - tickyPushUpdateFrame, - tickyUpdateFrameOmitted, - - tickyEnterDynCon, - tickyEnterStaticCon, - tickyEnterViaNode, - - tickyEnterFun, - tickyEnterThunk, - - tickyUpdateBhCaf, - tickyBlackHole, - tickyUnboxedTupleReturn, tickyVectoredReturn, - tickyReturnOldCon, tickyReturnNewCon, - - tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs, - tickyUnknownCall, tickySlowCallPat, - - staticTickyHdr, - ) where - -import ClosureInfo -import CgUtils -import CgMonad - -import OldCmm -import OldCmmUtils -import CLabel - -import Name -import Id -import IdInfo -import BasicTypes -import FastString -import Outputable -import Module - --- Turgid imports for showTypeCategory -import PrelNames -import TcType -import Type -import TyCon - -import DynFlags - -import Data.Maybe - ------------------------------------------------------------------------------ --- --- Ticky-ticky profiling --- ------------------------------------------------------------------------------ - -staticTickyHdr :: [CmmLit] --- krc: not using this right now -- --- in the new version of ticky-ticky, we --- don't change the closure layout. --- leave it defined, though, to avoid breaking --- other things. -staticTickyHdr = [] - -emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code -emitTickyCounter cl_info args on_stk - = ifTicky $ - do { mod_name <- getModuleName - ; dflags <- getDynFlags - ; fun_descr_lit <- newStringCLit (fun_descr dflags mod_name) - ; arg_descr_lit <- newStringCLit arg_descr - ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter --- krc: note that all the fields are I32 now; some were I16 before, --- but the code generator wasn't handling that properly and it led to chaos, --- panic and disorder. - [ mkIntCLit dflags 0, - mkIntCLit dflags (length args),-- Arity - mkIntCLit dflags on_stk, -- Words passed on stack - fun_descr_lit, - arg_descr_lit, - zeroCLit dflags, -- Entry count - zeroCLit dflags, -- Allocs - zeroCLit dflags -- Link - ] } - where - name = closureName cl_info - ticky_ctr_label = mkRednCountsLabel name NoCafRefs - arg_descr = map (showTypeCategory . idType) args - fun_descr dflags mod_name = ppr_for_ticky_name dflags mod_name name - --- When printing the name of a thing in a ticky file, we want to --- give the module name even for *local* things. We print --- just "x (M)" rather that "M.x" to distinguish them from the global kind. -ppr_for_ticky_name :: DynFlags -> Module -> Name -> String -ppr_for_ticky_name dflags mod_name name - | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name))) - | otherwise = showSDocDebug dflags (ppr name) - --- ----------------------------------------------------------------------------- --- Ticky stack frames - -tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code -tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr") -tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr") - --- ----------------------------------------------------------------------------- --- Ticky entries - -tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon, - tickyEnterStaticThunk, tickyEnterViaNode :: Code -tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr") -tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr") -tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr") -tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr") -tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr") - -tickyEnterThunk :: ClosureInfo -> Code -tickyEnterThunk cl_info - | isStaticClosure cl_info = tickyEnterStaticThunk - | otherwise = tickyEnterDynThunk - -tickyBlackHole :: Bool{-updatable-} -> Code -tickyBlackHole updatable - = ifTicky (bumpTickyCounter ctr) - where - ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr" - | otherwise = fsLit "UPD_BH_UPDATABLE_ctr" - -tickyUpdateBhCaf :: ClosureInfo -> Code -tickyUpdateBhCaf cl_info - = ifTicky (bumpTickyCounter ctr) - where - ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr" - | otherwise = fsLit "UPD_CAF_BH_UPDATABLE_ctr" - -tickyEnterFun :: ClosureInfo -> Code -tickyEnterFun cl_info - = ifTicky $ - do { dflags <- getDynFlags - ; bumpTickyCounter ctr - ; fun_ctr_lbl <- getTickyCtrLabel - ; registerTickyCtr fun_ctr_lbl - ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl (oFFSET_StgEntCounter_entry_count dflags)) - } - where - ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr" - | otherwise = fsLit "ENT_DYN_FUN_DIRECT_ctr" - -registerTickyCtr :: CLabel -> Code --- Register a ticky counter --- if ( ! f_ct.registeredp ) { --- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */ --- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ --- f_ct.registeredp = 1 } -registerTickyCtr ctr_lbl - = do dflags <- getDynFlags - let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead - test = CmmMachOp (MO_Eq (wordWidth dflags)) - [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags), - CmmLit (mkIntCLit dflags 0)] - register_stmts - = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) - (CmmLoad ticky_entry_ctrs (bWord dflags)) - , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl) - , CmmStore (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) - (CmmLit (mkIntCLit dflags 1)) ] - ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs")) - emitIf test (stmtsC register_stmts) - -tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code -tickyReturnOldCon arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr") - ; bumpHistogram (fsLit "RET_OLD_hst") arity } -tickyReturnNewCon arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr") - ; bumpHistogram (fsLit "RET_NEW_hst") arity } - -tickyUnboxedTupleReturn :: Int -> Code -tickyUnboxedTupleReturn arity - = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr") - ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity } - -tickyVectoredReturn :: Int -> Code -tickyVectoredReturn family_size - = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr") - ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size } - --- ----------------------------------------------------------------------------- --- Ticky calls - --- Ticks at a *call site*: -tickyKnownCallTooFewArgs, tickyKnownCallExact, - tickyKnownCallExtraArgs, tickyUnknownCall :: Code -tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr") -tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr") -tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr") -tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr") - --- Tick for the call pattern at slow call site (i.e. in addition to --- tickyUnknownCall, tickyKnownCallExtraArgs, etc.) -tickySlowCallPat :: [CgRep] -> Code -tickySlowCallPat _args = return () -{- LATER: (introduces recursive module dependency now). - case callPattern args of - (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat) - (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER") - -callPattern :: [CgRep] -> (String,Bool) -callPattern reps - | match == length reps = (chars, True) - | otherwise = (chars, False) - where (_,match) = findMatch reps - chars = map argChar reps - -argChar VoidArg = 'v' -argChar PtrArg = 'p' -argChar NonPtrArg = 'n' -argChar LongArg = 'l' -argChar FloatArg = 'f' -argChar DoubleArg = 'd' --} - --- ----------------------------------------------------------------------------- --- Ticky allocation - -tickyDynAlloc :: ClosureInfo -> Code --- Called when doing a dynamic heap allocation -tickyDynAlloc cl_info - = ifTicky $ - case cl_info of { - ConInfo {} -> tick_alloc_con ; - ClosureInfo { closureLFInfo = lf_info } -> - case lf_info of - LFCon {} -> tick_alloc_con - LFReEntrant {} -> tick_alloc_fun - LFThunk {} -> tick_alloc_thk - -- black hole - _ -> return () } - where - -- will be needed when we fill in stubs - -- _cl_size = closureSize dflags cl_info --- _slop_size = slopSize cl_info - - tick_alloc_thk - | closureUpdReqd cl_info = tick_alloc_up_thk - | otherwise = tick_alloc_se_thk - - -- krc: changed from panic to return () - -- just to get something working - tick_alloc_con = return () - tick_alloc_fun = return () - tick_alloc_up_thk = return () - tick_alloc_se_thk = return () - - -tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code -tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ()) - -tickyAllocThunk :: CmmExpr -> CmmExpr -> Code -tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ()) - -tickyAllocPAP :: CmmExpr -> CmmExpr -> Code -tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ()) - -tickyAllocHeap :: VirtualHpOffset -> Code --- Called when doing a heap check [TICK_ALLOC_HEAP] -tickyAllocHeap hp - = ifTicky $ - do { dflags <- getDynFlags - ; ticky_ctr <- getTickyCtrLabel - ; stmtsC $ - if hp == 0 then [] -- Inside the stmtC to avoid control - else [ -- dependency on the argument - -- Bump the allcoation count in the StgEntCounter - addToMem (typeWidth (rEP_StgEntCounter_allocs dflags)) - (CmmLit (cmmLabelOffB ticky_ctr - (oFFSET_StgEntCounter_allocs dflags))) hp, - -- Bump ALLOC_HEAP_ctr - addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1, - -- Bump ALLOC_HEAP_tot - addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] } - --- ----------------------------------------------------------------------------- --- Ticky utils - -ifTicky :: Code -> Code -ifTicky code = do dflags <- getDynFlags - if gopt Opt_Ticky dflags then code - else nopC - -addToMemLbl :: Width -> CLabel -> Int -> CmmStmt -addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n - --- All the ticky-ticky counters are declared "unsigned long" in C -bumpTickyCounter :: FastString -> Code -bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0) - -bumpTickyCounter' :: CmmLit -> Code --- krc: note that we're incrementing the _entry_count_ field of the ticky counter -bumpTickyCounter' lhs = do dflags <- getDynFlags - stmtC (addToMemLong dflags (CmmLit lhs) 1) - -bumpHistogram :: FastString -> Int -> Code -bumpHistogram _lbl _n --- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong)) - = return () -- TEMP SPJ Apr 07 - -{- -bumpHistogramE :: LitString -> CmmExpr -> Code -bumpHistogramE lbl n - = do t <- newTemp cLong - stmtC (CmmAssign (CmmLocal t) n) - emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $ - stmtC (CmmAssign (CmmLocal t) eight) - stmtC (addToMemLong (cmmIndexExpr cLongWidth - (CmmLit (CmmLabel (mkRtsDataLabel lbl))) - (CmmReg (CmmLocal t))) - 1) - where - eight = CmmLit (CmmInt 8 cLongWidth) --} - ------------------------------------------------------------------- -addToMemLong :: DynFlags -> CmmExpr -> Int -> CmmStmt -addToMemLong dflags = addToMem (cLongWidth dflags) - ------------------------------------------------------------------- --- Showing the "type category" for ticky-ticky profiling - -showTypeCategory :: Type -> Char - {- {C,I,F,D} char, int, float, double - T tuple - S other single-constructor type - {c,i,f,d} unboxed ditto - t *unpacked* tuple - s *unpacked" single-cons... - - v void# - a primitive array - - E enumeration type - + dictionary, unless it's a ... - L List - > function - M other (multi-constructor) data-con type - . other type - - reserved for others to mark as "uninteresting" - -} -showTypeCategory ty - = if isDictTy ty - then '+' - else - case tcSplitTyConApp_maybe ty of - Nothing -> if isJust (tcSplitFunTy_maybe ty) - then '>' - else '.' - - Just (tycon, _) -> - let utc = getUnique tycon in - if utc == charDataConKey then 'C' - else if utc == intDataConKey then 'I' - else if utc == floatDataConKey then 'F' - else if utc == doubleDataConKey then 'D' - else if utc == charPrimTyConKey then 'c' - else if (utc == intPrimTyConKey || utc == wordPrimTyConKey - || utc == addrPrimTyConKey) then 'i' - else if utc == floatPrimTyConKey then 'f' - else if utc == doublePrimTyConKey then 'd' - else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus - else if isEnumerationTyCon tycon then 'E' - else if isTupleTyCon tycon then 'T' - else if isJust (tyConSingleDataCon_maybe tycon) then 'S' - else if utc == listTyConKey then 'L' - else 'M' -- oh, well... diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 9f9a2cfe26..1f0b82532b 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -6,319 +6,16 @@ -- ----------------------------------------------------------------------------- -module CgUtils ( - addIdReps, - cgLit, - emitDataLits, mkDataLits, - emitRODataLits, mkRODataLits, - emitIf, emitIfThenElse, - emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, - emitRtsCallGen, - assignTemp, assignTemp_, newTemp, - emitSimultaneously, - emitSwitch, emitLitSwitch, - tagToClosure, - - callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, - activeStgRegs, fixStgRegisters, - - cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, - cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, - cmmOffsetExprW, cmmOffsetExprB, - cmmRegOffW, cmmRegOffB, - cmmLabelOffW, cmmLabelOffB, - cmmOffsetW, cmmOffsetB, - cmmOffsetLitW, cmmOffsetLitB, - cmmLoadIndexW, - cmmConstrTag, cmmConstrTag1, - - tagForCon, tagCons, isSmallFamily, - cmmUntag, cmmIsTagged, cmmGetTag, - - addToMem, addToMemE, - mkWordCLit, - newStringCLit, newByteStringCLit, - packHalfWordsCLit, - blankWord, - - getSRTInfo - ) where +module CgUtils ( fixStgRegisters ) where #include "HsVersions.h" -import BlockId import CodeGen.Platform -import CgMonad -import TyCon -import DataCon -import Id -import IdInfo -import SMRep import OldCmm -import OldCmmUtils import CLabel -import ForeignCall -import ClosureInfo -import StgSyn (SRT(..)) -import Module -import Literal -import Digraph -import ListSetOps -import Util import DynFlags -import FastString import Outputable -import Data.Char -import Data.Word -import Data.List -import Data.Maybe -import Data.Ord - -------------------------------------------------------------------------- --- --- Random small functions --- -------------------------------------------------------------------------- - -addIdReps :: [Id] -> [(CgRep, Id)] -addIdReps ids = [(idCgRep id, id) | id <- ids] - -------------------------------------------------------------------------- --- --- Literals --- -------------------------------------------------------------------------- - -cgLit :: Literal -> FCode CmmLit -cgLit (MachStr s) = newByteStringCLit (bytesFB s) -cgLit other_lit = do dflags <- getDynFlags - return (mkSimpleLit dflags other_lit) - -mkSimpleLit :: DynFlags -> Literal -> CmmLit -mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags) -mkSimpleLit dflags MachNullAddr = zeroCLit dflags -mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (MachInt64 i) = CmmInt i W64 -mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags) -mkSimpleLit _ (MachWord64 i) = CmmInt i W64 -mkSimpleLit _ (MachFloat r) = CmmFloat r W32 -mkSimpleLit _ (MachDouble r) = CmmFloat r W64 -mkSimpleLit _ (MachLabel fs ms fod) - = CmmLabel (mkForeignLabel fs ms labelSrc fod) - where - -- TODO: Literal labels might not actually be in the current package... - labelSrc = ForeignLabelInThisPackage -mkSimpleLit _ (MachStr _) = panic "mkSimpleLit: MachStr" --- No LitInteger's should be left by the time this is called. CorePrep --- should have converted them all to a real core representation. -mkSimpleLit _ (LitInteger {}) = panic "mkSimpleLit: LitInteger" - -mkLtOp :: DynFlags -> Literal -> MachOp --- On signed literals we must do a signed comparison -mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags) -mkLtOp _ (MachFloat _) = MO_F_Lt W32 -mkLtOp _ (MachDouble _) = MO_F_Lt W64 -mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit))) - - ---------------------------------------------------- --- --- Cmm data type functions --- ---------------------------------------------------- - - - -{- - The family size of a data type (the number of constructors) - can be either: - * small, if the family size < 2**tag_bits - * big, otherwise. - - Small families can have the constructor tag in the tag - bits. - Big families only use the tag value 1 to represent - evaluatedness. --} -isSmallFamily :: DynFlags -> Int -> Bool -isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags - -tagForCon :: DynFlags -> DataCon -> ConTagZ -tagForCon dflags con = tag - where - con_tag = dataConTagZ con - fam_size = tyConFamilySize (dataConTyCon con) - tag | isSmallFamily dflags fam_size = con_tag + 1 - | otherwise = 1 - ---Tag an expression, to do: refactor, this appears in some other module. -tagCons :: DynFlags -> DataCon -> CmmExpr -> CmmExpr -tagCons dflags con expr = cmmOffsetB dflags expr (tagForCon dflags con) - --------------------------------------------------------------------------- --- --- Incrementing a memory location --- --------------------------------------------------------------------------- - -addToMem :: Width -- rep of the counter - -> CmmExpr -- Address - -> Int -- What to add (a word) - -> CmmStmt -addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width)) - -addToMemE :: Width -- rep of the counter - -> CmmExpr -- Address - -> CmmExpr -- What to add (a word-typed expression) - -> CmmStmt -addToMemE width ptr n - = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n]) - -------------------------------------------------------------------------- --- --- Converting a closure tag to a closure for enumeration types --- (this is the implementation of tagToEnum#). --- -------------------------------------------------------------------------- - -tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr -tagToClosure dflags tycon tag - = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (gcWord dflags) - where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs - -------------------------------------------------------------------------- --- --- Conditionals and rts calls --- -------------------------------------------------------------------------- - -emitIf :: CmmExpr -- Boolean - -> Code -- Then part - -> Code --- Emit (if e then x) --- ToDo: reverse the condition to avoid the extra branch instruction if possible --- (some conditionals aren't reversible. eg. floating point comparisons cannot --- be inverted because there exist some values for which both comparisons --- return False, such as NaN.) -emitIf cond then_part - = do { then_id <- newLabelC - ; join_id <- newLabelC - ; stmtC (CmmCondBranch cond then_id) - ; stmtC (CmmBranch join_id) - ; labelC then_id - ; then_part - ; labelC join_id - } - -emitIfThenElse :: CmmExpr -- Boolean - -> Code -- Then part - -> Code -- Else part - -> Code --- Emit (if e then x else y) -emitIfThenElse cond then_part else_part - = do { then_id <- newLabelC - ; join_id <- newLabelC - ; stmtC (CmmCondBranch cond then_id) - ; else_part - ; stmtC (CmmBranch join_id) - ; labelC then_id - ; then_part - ; labelC join_id - } - - --- | Emit code to call a Cmm function. -emitRtsCall - :: PackageId -- ^ package the function is in - -> FastString -- ^ name of function - -> [CmmHinted CmmExpr] -- ^ function args - -> Code -- ^ cmm code - -emitRtsCall pkg fun args = emitRtsCallGen [] pkg fun args Nothing - -- The 'Nothing' says "save all global registers" - -emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Code -emitRtsCallWithVols pkg fun args vols - = emitRtsCallGen [] pkg fun args (Just vols) - -emitRtsCallWithResult - :: LocalReg -> ForeignHint - -> PackageId -> FastString - -> [CmmHinted CmmExpr] -> Code - -emitRtsCallWithResult res hint pkg fun args - = emitRtsCallGen [CmmHinted res hint] pkg fun args Nothing - --- Make a call to an RTS C procedure -emitRtsCallGen - :: [CmmHinted LocalReg] - -> PackageId - -> FastString - -> [CmmHinted CmmExpr] - -> Maybe [GlobalReg] - -> Code -emitRtsCallGen res pkg fun args vols = do - dflags <- getDynFlags - let (caller_save, caller_load) = callerSaveVolatileRegs dflags vols - stmtsC caller_save - stmtC (CmmCall target res args CmmMayReturn) - stmtsC caller_load - where - target = CmmCallee fun_expr CCallConv - fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) - ------------------------------------------------------------------------------ --- --- Caller-Save Registers --- ------------------------------------------------------------------------------ - --- Here we generate the sequence of saves/restores required around a --- foreign call instruction. - --- TODO: reconcile with includes/Regs.h --- * Regs.h claims that BaseReg should be saved last and loaded first --- * This might not have been tickled before since BaseReg is callee save --- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim -callerSaveVolatileRegs :: DynFlags -> Maybe [GlobalReg] - -> ([CmmStmt], [CmmStmt]) -callerSaveVolatileRegs dflags vols = (caller_save, caller_load) - where - platform = targetPlatform dflags - - caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save) - caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save) - - system_regs = [Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery, - {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ] - - regs_to_save = system_regs ++ vol_list - - vol_list = case vols of Nothing -> all_of_em; Just regs -> regs - - all_of_em = [ VanillaReg n VNonGcPtr | n <- [0 .. mAX_Vanilla_REG dflags] ] - -- The VNonGcPtr is a lie, but I don't think it matters - ++ [ FloatReg n | n <- [0 .. mAX_Float_REG dflags] ] - ++ [ DoubleReg n | n <- [0 .. mAX_Double_REG dflags] ] - ++ [ LongReg n | n <- [0 .. mAX_Long_REG dflags] ] - - callerSaveGlobalReg reg next - | callerSaves platform reg = - CmmStore (get_GlobalReg_addr dflags reg) - (CmmReg (CmmGlobal reg)) : next - | otherwise = next - - callerRestoreGlobalReg reg next - | callerSaves platform reg = - CmmAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr dflags reg) - (globalRegType dflags reg)) - : next - | otherwise = next - - -- ----------------------------------------------------------------------------- -- Information about global registers @@ -360,457 +57,6 @@ baseRegOffset _ BaseReg = panic "baseRegOffset:BaseReg" baseRegOffset _ PicBaseReg = panic "baseRegOffset:PicBaseReg" -------------------------------------------------------------------------- --- --- Strings generate a top-level data block --- -------------------------------------------------------------------------- - -emitDataLits :: CLabel -> [CmmLit] -> Code --- Emit a data-segment data block -emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits) - -emitRODataLits :: String -> CLabel -> [CmmLit] -> Code --- Emit a read-only data block -emitRODataLits _caller lbl lits - = emitDecl (mkRODataLits lbl lits) - -newStringCLit :: String -> FCode CmmLit --- Make a global definition for the string, --- and return its label -newStringCLit str = newByteStringCLit (map (fromIntegral.ord) str) - -newByteStringCLit :: [Word8] -> FCode CmmLit -newByteStringCLit bytes - = do { uniq <- newUnique - ; let (lit, decl) = mkByteStringCLit uniq bytes - ; emitDecl decl - ; return lit } - -------------------------------------------------------------------------- --- --- Assigning expressions to temporaries --- -------------------------------------------------------------------------- - --- | If the expression is trivial, return it. Otherwise, assign the --- expression to a temporary register and return an expression --- referring to this register. -assignTemp :: CmmExpr -> FCode CmmExpr --- For a non-trivial expression, e, create a local --- variable and assign the expression to it -assignTemp e - | isTrivialCmmExpr e = return e - | otherwise = do dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) - stmtC (CmmAssign (CmmLocal reg) e) - return (CmmReg (CmmLocal reg)) - --- | If the expression is trivial and doesn't refer to a global --- register, return it. Otherwise, assign the expression to a --- temporary register and return an expression referring to this --- register. -assignTemp_ :: CmmExpr -> FCode CmmExpr -assignTemp_ e - | isTrivialCmmExpr e && hasNoGlobalRegs e = return e - | otherwise = do - dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) - stmtC (CmmAssign (CmmLocal reg) e) - return (CmmReg (CmmLocal reg)) - -newTemp :: CmmType -> FCode LocalReg -newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) } - -------------------------------------------------------------------------- --- --- Building case analysis --- -------------------------------------------------------------------------- - -emitSwitch - :: CmmExpr -- Tag to switch on - -> [(ConTagZ, CgStmts)] -- Tagged branches - -> Maybe CgStmts -- Default branch (if any) - -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour - -- outside this range is undefined - -> Code - --- ONLY A DEFAULT BRANCH: no case analysis to do -emitSwitch _ [] (Just stmts) _ _ - = emitCgStmts stmts - --- Right, off we go -emitSwitch tag_expr branches mb_deflt lo_tag hi_tag - = -- Just sort the branches before calling mk_sritch - do { mb_deflt_id <- - case mb_deflt of - Nothing -> return Nothing - Just stmts -> do id <- forkCgStmts stmts; return (Just id) - - ; dflags <- getDynFlags - ; let via_C | HscC <- hscTarget dflags = True - | otherwise = False - - ; stmts <- mk_switch tag_expr (sortBy (comparing fst) branches) - mb_deflt_id lo_tag hi_tag via_C - ; emitCgStmts stmts - } - - -mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)] - -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool - -> FCode CgStmts - --- SINGLETON TAG RANGE: no case analysis to do -mk_switch _tag_expr [(tag,stmts)] _ lo_tag hi_tag _via_C - | lo_tag == hi_tag - = ASSERT( tag == lo_tag ) - return stmts - --- SINGLETON BRANCH, NO DEFAULT: no case analysis to do -mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C - = return stmts - -- The simplifier might have eliminated a case - -- so we may have e.g. case xs of - -- [] -> e - -- In that situation we can be sure the (:) case - -- can't happen, so no need to test - --- SINGLETON BRANCH: one equality check to do -mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C = do - dflags <- getDynFlags - let - cond = cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag)) - -- We have lo_tag < hi_tag, but there's only one branch, - -- so there must be a default - return (CmmCondBranch cond deflt `consCgStmt` stmts) - --- ToDo: we might want to check for the two branch case, where one of --- the branches is the tag 0, because comparing '== 0' is likely to be --- more efficient than other kinds of comparison. - --- DENSE TAG RANGE: use a switch statment. --- --- We also use a switch uncoditionally when compiling via C, because --- this will get emitted as a C switch statement and the C compiler --- should do a good job of optimising it. Also, older GCC versions --- (2.95 in particular) have problems compiling the complicated --- if-trees generated by this code, so compiling to a switch every --- time works around that problem. --- -mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C - | use_switch -- Use a switch - = do { dflags <- getDynFlags - ; branch_ids <- mapM forkCgStmts (map snd branches) - ; let - tagged_blk_ids = zip (map fst branches) (map Just branch_ids) - - find_branch :: ConTagZ -> Maybe BlockId - find_branch i = assocDefault mb_deflt tagged_blk_ids i - - -- NB. we have eliminated impossible branches at - -- either end of the range (see below), so the first - -- tag of a real branch is real_lo_tag (not lo_tag). - arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]] - - switch_stmt = CmmSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms - - ; ASSERT(not (all isNothing arms)) - return (oneCgStmt switch_stmt) - } - - -- if we can knock off a bunch of default cases with one if, then do so - | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches - = do { dflags <- getDynFlags - ; (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch)) - branch = CmmCondBranch cond deflt - ; stmts <- mk_switch tag_expr' branches mb_deflt - lowest_branch hi_tag via_C - ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts)) - } - - | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches - = do { dflags <- getDynFlags - ; (assign_tag, tag_expr') <- assignTemp' tag_expr - ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch)) - branch = CmmCondBranch cond deflt - ; stmts <- mk_switch tag_expr' branches mb_deflt - lo_tag highest_branch via_C - ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts)) - } - - | otherwise -- Use an if-tree - = do { dflags <- getDynFlags - ; (assign_tag, tag_expr') <- assignTemp' tag_expr - -- To avoid duplication - ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt - lo_tag (mid_tag-1) via_C - ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt - mid_tag hi_tag via_C - ; hi_id <- forkCgStmts hi_stmts - ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag)) - branch_stmt = CmmCondBranch cond hi_id - ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts)) - } - -- we test (e >= mid_tag) rather than (e < mid_tag), because - -- the former works better when e is a comparison, and there - -- are two tags 0 & 1 (mid_tag == 1). In this case, the code - -- generator can reduce the condition to e itself without - -- having to reverse the sense of the comparison: comparisons - -- can't always be easily reversed (eg. floating - -- pt. comparisons). - where - use_switch = {- pprTrace "mk_switch" ( - ppr tag_expr <+> text "n_tags:" <+> int n_tags <+> - text "branches:" <+> ppr (map fst branches) <+> - text "n_branches:" <+> int n_branches <+> - text "lo_tag:" <+> int lo_tag <+> - text "hi_tag:" <+> int hi_tag <+> - text "real_lo_tag:" <+> int real_lo_tag <+> - text "real_hi_tag:" <+> int real_hi_tag) $ -} - ASSERT( n_branches > 1 && n_tags > 1 ) - n_tags > 2 && (via_C || (dense && big_enough)) - -- up to 4 branches we use a decision tree, otherwise - -- a switch (== jump table in the NCG). This seems to be - -- optimal, and corresponds with what gcc does. - big_enough = n_branches > 4 - dense = n_branches > (n_tags `div` 2) - n_branches = length branches - - -- ignore default slots at each end of the range if there's - -- no default branch defined. - lowest_branch = fst (head branches) - highest_branch = fst (last branches) - - real_lo_tag - | isNothing mb_deflt = lowest_branch - | otherwise = lo_tag - - real_hi_tag - | isNothing mb_deflt = highest_branch - | otherwise = hi_tag - - n_tags = real_hi_tag - real_lo_tag + 1 - - -- INVARIANT: Provided hi_tag > lo_tag (which is true) - -- lo_tag <= mid_tag < hi_tag - -- lo_branches have tags < mid_tag - -- hi_branches have tags >= mid_tag - - (mid_tag,_) = branches !! (n_branches `div` 2) - -- 2 branches => n_branches `div` 2 = 1 - -- => branches !! 1 give the *second* tag - -- There are always at least 2 branches here - - (lo_branches, hi_branches) = span is_lo branches - is_lo (t,_) = t < mid_tag - -assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr) -assignTemp' e - | isTrivialCmmExpr e = return (CmmNop, e) - | otherwise = do dflags <- getDynFlags - reg <- newTemp (cmmExprType dflags e) - return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) - -emitLitSwitch :: CmmExpr -- Tag to switch on - -> [(Literal, CgStmts)] -- Tagged branches - -> CgStmts -- Default branch (always) - -> Code -- Emit the code --- Used for general literals, whose size might not be a word, --- where there is always a default case, and where we don't know --- the range of values for certain. For simplicity we always generate a tree. --- --- ToDo: for integers we could do better here, perhaps by generalising --- mk_switch and using that. --SDM 15/09/2004 -emitLitSwitch _ [] deflt = emitCgStmts deflt -emitLitSwitch scrut branches deflt_blk - = do { scrut' <- assignTemp scrut - ; deflt_blk_id <- forkCgStmts deflt_blk - ; blk <- mk_lit_switch scrut' deflt_blk_id (sortBy (comparing fst) branches) - ; emitCgStmts blk } - -mk_lit_switch :: CmmExpr -> BlockId - -> [(Literal,CgStmts)] - -> FCode CgStmts -mk_lit_switch scrut deflt_blk_id [(lit,blk)] - = do dflags <- getDynFlags - let cmm_lit = mkSimpleLit dflags lit - rep = cmmLitType dflags cmm_lit - ne = if isFloatType rep then MO_F_Ne else MO_Ne - cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit] - if_stmt = CmmCondBranch cond deflt_blk_id - return (consCgStmt if_stmt blk) - -mk_lit_switch scrut deflt_blk_id branches - = do { dflags <- getDynFlags - ; hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches - ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches - ; lo_blk_id <- forkCgStmts lo_blk - ; let if_stmt = CmmCondBranch (cond dflags) lo_blk_id - ; return (if_stmt `consCgStmt` hi_blk) } - where - n_branches = length branches - (mid_lit,_) = branches !! (n_branches `div` 2) - -- See notes above re mid_tag - - (lo_branches, hi_branches) = span is_lo branches - is_lo (t,_) = t < mid_lit - - cond dflags = CmmMachOp (mkLtOp dflags mid_lit) - [scrut, CmmLit (mkSimpleLit dflags mid_lit)] - -------------------------------------------------------------------------- --- --- Simultaneous assignment --- -------------------------------------------------------------------------- - - -emitSimultaneously :: CmmStmts -> Code --- Emit code to perform the assignments in the --- input simultaneously, using temporary variables when necessary. --- --- The Stmts must be: --- CmmNop, CmmComment, CmmAssign, CmmStore --- and nothing else - - --- We use the strongly-connected component algorithm, in which --- * the vertices are the statements --- * an edge goes from s1 to s2 iff --- s1 assigns to something s2 uses --- that is, if s1 should *follow* s2 in the final order - -type CVertex = (Int, CmmStmt) -- Give each vertex a unique number, - -- for fast comparison - -emitSimultaneously stmts - = codeOnly $ - case filterOut isNopStmt (stmtList stmts) of - -- Remove no-ops - [] -> nopC - [stmt] -> stmtC stmt -- It's often just one stmt - stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list) - -doSimultaneously1 :: [CVertex] -> Code -doSimultaneously1 vertices = do - dflags <- getDynFlags - let - edges = [ (vertex, key1, edges_from stmt1) - | vertex@(key1, stmt1) <- vertices - ] - edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices, - mustFollow dflags stmt1 stmt2 - ] - components = stronglyConnCompFromEdgedVertices edges - - -- do_components deal with one strongly-connected component - -- Not cyclic, or singleton? Just do it - do_component (AcyclicSCC (_n, stmt)) = stmtC stmt - do_component (CyclicSCC []) - = panic "doSimultaneously1: do_component (CyclicSCC [])" - do_component (CyclicSCC [(_n, stmt)]) = stmtC stmt - - -- Cyclic? Then go via temporaries. Pick one to - -- break the loop and try again with the rest. - do_component (CyclicSCC ((_n, first_stmt) : rest)) - = do { from_temp <- go_via_temp first_stmt - ; doSimultaneously1 rest - ; stmtC from_temp } - - go_via_temp (CmmAssign dest src) - = do { dflags <- getDynFlags - ; tmp <- newTemp (cmmRegType dflags dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong - ; stmtC (CmmAssign (CmmLocal tmp) src) - ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) } - go_via_temp (CmmStore dest src) - = do { tmp <- newTemp (cmmExprType dflags src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong - ; stmtC (CmmAssign (CmmLocal tmp) src) - ; return (CmmStore dest (CmmReg (CmmLocal tmp))) } - go_via_temp _ = panic "doSimultaneously1: go_via_temp" - mapCs do_component components - -mustFollow :: DynFlags -> CmmStmt -> CmmStmt -> Bool -mustFollow dflags x y = x `mustFollow'` y - where CmmAssign reg _ `mustFollow'` stmt = anySrc (reg `regUsedIn`) stmt - CmmStore loc e `mustFollow'` stmt = anySrc (locUsedIn loc (cmmExprType dflags e)) stmt - CmmNop `mustFollow'` _ = False - CmmComment _ `mustFollow'` _ = False - _ `mustFollow'` _ = panic "mustFollow" - - -anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool --- True if the fn is true of any input of the stmt -anySrc p (CmmAssign _ e) = p e -anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side -anySrc _ (CmmComment _) = False -anySrc _ CmmNop = False -anySrc _ _ = True -- Conservative - -locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool --- (locUsedIn a r e) checks whether writing to r[a] could affect the value of --- 'e'. Returns True if it's not sure. -locUsedIn _ _ (CmmLit _) = False -locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep -locUsedIn _ _ (CmmReg _) = False -locUsedIn _ _ (CmmRegOff _ _) = False -locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es -locUsedIn _ _ (CmmStackSlot _ _) = panic "locUsedIn: CmmStackSlot" - -possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool --- Assumes that distinct registers (eg Hp, Sp) do not --- point to the same location, nor any offset thereof. -possiblySameLoc (CmmReg r1) _ (CmmReg r2) _ = r1 == r2 -possiblySameLoc (CmmReg r1) _ (CmmRegOff r2 0) _ = r1 == r2 -possiblySameLoc (CmmRegOff r1 0) _ (CmmReg r2) _ = r1 == r2 -possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2 - = r1==r2 && end1 > start2 && end2 > start1 - where - end1 = start1 + widthInBytes (typeWidth rep1) - end2 = start2 + widthInBytes (typeWidth rep2) - -possiblySameLoc _ _ (CmmLit _) _ = False -possiblySameLoc _ _ _ _ = True -- Conservative - -------------------------------------------------------------------------- --- --- Static Reference Tables --- -------------------------------------------------------------------------- - --- 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. - -getSRTInfo :: FCode C_SRT -getSRTInfo = do - dflags <- getDynFlags - srt_lbl <- getSRTLabel - srt <- getSRT - case srt of - -- TODO: Should we panic in this case? - -- Someone obviously thinks there should be an SRT - NoSRT -> return NoC_SRT - SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?" - SRT off len bmp - | len > hALF_WORD_SIZE_IN_BITS dflags || bmp == [toStgWord dflags (fromStgHalfWord (srt_escape dflags))] - -> do id <- newUnique - let srt_desc_lbl = mkLargeSRTLabel id - emitRODataLits "getSRTInfo" srt_desc_lbl - ( cmmLabelOffW dflags srt_lbl off - : mkWordCLit dflags (toInteger len) - : map (mkWordCLit dflags . fromStgWord) bmp) - return (C_SRT srt_desc_lbl 0 (srt_escape dflags)) - - | otherwise - -> return (C_SRT srt_lbl off (toStgHalfWord dflags (fromStgWord (head bmp)))) - -- The fromIntegral converts to StgHalfWord - -srt_escape :: DynFlags -> StgHalfWord -srt_escape dflags = toStgHalfWord dflags (-1) - -- ----------------------------------------------------------------------------- -- -- STG/Cmm GlobalReg diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs deleted file mode 100644 index 7371ca56a2..0000000000 --- a/compiler/codeGen/ClosureInfo.lhs +++ /dev/null @@ -1,1122 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The Univserity of Glasgow 1992-2004 -% - - Data structures which describe closures, and - operations over those data structures - - Nothing monadic in here - -Much of the rationale for these things is in the ``details'' part of -the STG paper. - -\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 ClosureInfo ( - idRepArity, - - ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but - StandardFormInfo(..), -- mkCmmInfo looks inside - SMRep, - - ArgDescr(..), Liveness, - C_SRT(..), needsSRT, - - mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, - mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, - - mkClosureInfo, mkConInfo, maybeIsLFCon, - closureSize, - - ConTagZ, dataConTagZ, - - infoTableLabelFromCI, entryLabelFromCI, - closureLabelFromCI, - isLFThunk, closureUpdReqd, - closureNeedsUpdSpace, closureIsThunk, - closureSingleEntry, closureReEntrant, isConstrClosure_maybe, - closureFunInfo, isKnownFun, - funTag, funTagLFInfo, tagForArity, clHasCafRefs, - - enterIdLabel, enterReturnPtLabel, - - nodeMustPointToIt, - CallMethod(..), getCallMethod, - - blackHoleOnEntry, - - staticClosureRequired, - - isToplevClosure, - closureValDescr, closureTypeDescr, -- profiling - - isStaticClosure, - cafBlackHoleClosureInfo, - - staticClosureNeedsLink, - - -- CgRep and its functions - CgRep(..), nonVoidArg, - argMachRep, primRepToCgRep, - isFollowableArg, isVoidArg, - isFloatingArg, is64BitArg, - separateByPtrFollowness, - cgRepSizeW, cgRepSizeB, - retAddrSizeW, - typeCgRep, idCgRep, tyConCgRep, - - ) where - -#include "../includes/MachDeps.h" -#include "HsVersions.h" - -import StgSyn -import SMRep - -import CLabel -import Cmm -import Unique -import Var -import Id -import IdInfo -import DataCon -import Name -import Type -import TypeRep -import TcType -import TyCon -import BasicTypes -import Outputable -import FastString -import Constants -import DynFlags -import Util -\end{code} - - -%************************************************************************ -%* * -\subsection[ClosureInfo-datatypes]{Data types for closure information} -%* * -%************************************************************************ - -Information about a closure, from the code generator's point of view. - -A ClosureInfo decribes the info pointer of a closure. It has -enough information - a) to construct the info table itself - b) to allocate a closure containing that info pointer (i.e. - it knows the info table label) - -We make a ClosureInfo for - - each let binding (both top level and not) - - each data constructor (for its shared static and - dynamic info tables) - -\begin{code} -data ClosureInfo - = ClosureInfo { - closureName :: !Name, -- The thing bound to this closure - closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below) - closureSMRep :: !SMRep, -- representation used by storage mgr - closureSRT :: !C_SRT, -- What SRT applies to this closure - closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String, -- closure description (for profiling) - closureInfLcl :: Bool -- can the info pointer be a local symbol? - } - - -- Constructor closures don't have a unique info table label (they use - -- the constructor's info table), and they don't have an SRT. - | ConInfo { - closureCon :: !DataCon, - closureSMRep :: !SMRep - } -\end{code} - -%************************************************************************ -%* * -\subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info} -%* * -%************************************************************************ - -Information about an identifier, from the code generator's point of -view. Every identifier is bound to a LambdaFormInfo in the -environment, which gives the code generator enough info to be able to -tail call or return that identifier. - -Note that a closure is usually bound to an identifier, so a -ClosureInfo contains a LambdaFormInfo. - -\begin{code} -data LambdaFormInfo - = LFReEntrant -- Reentrant closure (a function) - TopLevelFlag -- True if top level - !RepArity -- Arity. Invariant: always > 0 - !Bool -- True <=> no fvs - ArgDescr -- Argument descriptor (should reall be in ClosureInfo) - - | LFCon -- A saturated constructor application - DataCon -- The constructor - - | LFThunk -- Thunk (zero arity) - TopLevelFlag - !Bool -- True <=> no free vars - !Bool -- True <=> updatable (i.e., *not* single-entry) - StandardFormInfo - !Bool -- True <=> *might* be a function type - - | LFUnknown -- Used for function arguments and imported things. - -- We know nothing about this closure. Treat like - -- updatable "LFThunk"... - -- Imported things which we do know something about use - -- one of the other LF constructors (eg LFReEntrant for - -- known functions) - !Bool -- True <=> *might* be a function type - - | LFLetNoEscape -- See LetNoEscape module for precise description of - -- these "lets". - !RepArity -- arity; - - | LFBlackHole -- Used for the closures allocated to hold the result - -- of a CAF. We want the target of the update frame to - -- be in the heap, so we make a black hole to hold it. - - - -------------------------- --- StandardFormInfo tells whether this thunk has one of --- a small number of standard forms - -data StandardFormInfo - = NonStandardThunk - -- Not of of the standard forms - - | SelectorThunk - -- A SelectorThunk is of form - -- case x of - -- con a1,..,an -> ak - -- and the constructor is from a single-constr type. - WordOff -- 0-origin offset of ak within the "goods" of - -- constructor (Recall that the a1,...,an may be laid - -- out in the heap in a non-obvious order.) - - | ApThunk - -- An ApThunk is of form - -- x1 ... xn - -- The code for the thunk just pushes x2..xn on the stack and enters x1. - -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled - -- in the RTS to save space. - RepArity -- Arity, n -\end{code} - - -%************************************************************************ -%* * - CgRep -%* * -%************************************************************************ - -An CgRep is an abstraction of a Type which tells the code generator -all it needs to know about the calling convention for arguments (and -results) of that type. In particular, the ArgReps of a function's -arguments are used to decide which of the RTS's generic apply -functions to call when applying an unknown function. - -It contains more information than the back-end data type MachRep, -so one can easily convert from CgRep -> MachRep. (Except that -there's no MachRep for a VoidRep.) - -It distinguishes - pointers from non-pointers (we sort the pointers together - when building closures) - - void from other types: a void argument is different from no argument - -All 64-bit types map to the same CgRep, because they're passed in the -same register, but a PtrArg is still different from an NonPtrArg -because the function's entry convention has to take into account the -pointer-hood of arguments for the purposes of describing the stack on -entry to the garbage collector. - -\begin{code} -data CgRep - = VoidArg -- Void - | PtrArg -- Word-sized heap pointer, followed - -- by the garbage collector - | NonPtrArg -- Word-sized non-pointer - -- (including addresses not followed by GC) - | LongArg -- 64-bit non-pointer - | FloatArg -- 32-bit float - | DoubleArg -- 64-bit float - deriving Eq - -instance Outputable CgRep where - ppr VoidArg = ptext (sLit "V_") - ppr PtrArg = ptext (sLit "P_") - ppr NonPtrArg = ptext (sLit "I_") - ppr LongArg = ptext (sLit "L_") - ppr FloatArg = ptext (sLit "F_") - ppr DoubleArg = ptext (sLit "D_") - -argMachRep :: DynFlags -> CgRep -> CmmType -argMachRep dflags PtrArg = gcWord dflags -argMachRep dflags NonPtrArg = bWord dflags -argMachRep _ LongArg = b64 -argMachRep _ FloatArg = f32 -argMachRep _ DoubleArg = f64 -argMachRep _ VoidArg = panic "argMachRep:VoidRep" - -primRepToCgRep :: PrimRep -> CgRep -primRepToCgRep VoidRep = VoidArg -primRepToCgRep PtrRep = PtrArg -primRepToCgRep IntRep = NonPtrArg -primRepToCgRep WordRep = NonPtrArg -primRepToCgRep Int64Rep = LongArg -primRepToCgRep Word64Rep = LongArg -primRepToCgRep AddrRep = NonPtrArg -primRepToCgRep FloatRep = FloatArg -primRepToCgRep DoubleRep = DoubleArg - -idCgRep :: Id -> CgRep -idCgRep x = typeCgRep . idType $ x - -tyConCgRep :: TyCon -> CgRep -tyConCgRep = primRepToCgRep . tyConPrimRep - -typeCgRep :: UnaryType -> CgRep -typeCgRep = primRepToCgRep . typePrimRep -\end{code} - -Whether or not the thing is a pointer that the garbage-collector -should follow. Or, to put it another (less confusing) way, whether -the object in question is a heap object. - -Depending on the outcome, this predicate determines what stack -the pointer/object possibly will have to be saved onto, and the -computation of GC liveness info. - -\begin{code} -isFollowableArg :: CgRep -> Bool -- True <=> points to a heap object -isFollowableArg PtrArg = True -isFollowableArg _ = False - -isVoidArg :: CgRep -> Bool -isVoidArg VoidArg = True -isVoidArg _ = False - -nonVoidArg :: CgRep -> Bool -nonVoidArg VoidArg = False -nonVoidArg _ = True - --- isFloatingArg is used to distinguish @Double@ and @Float@ which --- cause inadvertent numeric conversions if you aren't jolly careful. --- See codeGen/CgCon:cgTopRhsCon. - -isFloatingArg :: CgRep -> Bool -isFloatingArg DoubleArg = True -isFloatingArg FloatArg = True -isFloatingArg _ = False - -is64BitArg :: CgRep -> Bool -is64BitArg LongArg = True -is64BitArg _ = False -\end{code} - -\begin{code} -separateByPtrFollowness :: [(CgRep,a)] -> ([(CgRep,a)], [(CgRep,a)]) --- Returns (ptrs, non-ptrs) -separateByPtrFollowness things - = sep_things things [] [] - -- accumulating params for follow-able and don't-follow things... - where - sep_things [] bs us = (reverse bs, reverse us) - sep_things ((PtrArg,a):ts) bs us = sep_things ts ((PtrArg,a):bs) us - sep_things (t :ts) bs us = sep_things ts bs (t:us) -\end{code} - -\begin{code} -cgRepSizeB :: DynFlags -> CgRep -> ByteOff -cgRepSizeB dflags DoubleArg = dOUBLE_SIZE dflags -cgRepSizeB _ LongArg = wORD64_SIZE -cgRepSizeB _ VoidArg = 0 -cgRepSizeB dflags _ = wORD_SIZE dflags - -cgRepSizeW :: DynFlags -> CgRep -> ByteOff -cgRepSizeW dflags DoubleArg = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags -cgRepSizeW dflags LongArg = wORD64_SIZE `quot` wORD_SIZE dflags -cgRepSizeW _ VoidArg = 0 -cgRepSizeW _ _ = 1 - -retAddrSizeW :: WordOff -retAddrSizeW = 1 -- One word -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-construction]{Functions which build LFInfos} -%* * -%************************************************************************ - -\begin{code} -mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> [Id] -- Args - -> ArgDescr -- Argument descriptor - -> LambdaFormInfo - -mkLFReEntrant top fvs args arg_descr - = LFReEntrant top (length args) (null fvs) arg_descr - -mkLFThunk :: Type -> TopLevelFlag -> [Var] -> UpdateFlag -> LambdaFormInfo -mkLFThunk thunk_ty top fvs upd_flag - = ASSERT2( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty), ppr thunk_ty $$ ppr fvs ) - LFThunk top (null fvs) - (isUpdatable upd_flag) - NonStandardThunk - (might_be_a_function thunk_ty) - -might_be_a_function :: Type -> Bool --- Return False only if we are *sure* it's a data type --- Look through newtypes etc as much as poss -might_be_a_function ty - | UnaryRep rep <- repType ty - , Just tc <- tyConAppTyCon_maybe rep - , isDataTyCon tc - = False - | otherwise - = True -\end{code} - -@mkConLFInfo@ is similar, for constructors. - -\begin{code} -mkConLFInfo :: DataCon -> LambdaFormInfo -mkConLFInfo con = LFCon con - -maybeIsLFCon :: LambdaFormInfo -> Maybe DataCon -maybeIsLFCon (LFCon con) = Just con -maybeIsLFCon _ = Nothing - -mkSelectorLFInfo :: Id -> WordOff -> Bool -> LambdaFormInfo -mkSelectorLFInfo id offset updatable - = LFThunk NotTopLevel False updatable (SelectorThunk offset) - (might_be_a_function (idType id)) - -mkApLFInfo :: Id -> UpdateFlag -> RepArity -> LambdaFormInfo -mkApLFInfo id upd_flag arity - = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) - (might_be_a_function (idType id)) -\end{code} - -Miscellaneous LF-infos. - -\begin{code} -mkLFArgument :: Id -> LambdaFormInfo -mkLFArgument id = LFUnknown (might_be_a_function (idType id)) - -mkLFLetNoEscape :: RepArity -> LambdaFormInfo -mkLFLetNoEscape = LFLetNoEscape - -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id - = case idRepArity id of - n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0 - _ -> mkLFArgument id -- Not sure of exact arity -\end{code} - -\begin{code} -isLFThunk :: LambdaFormInfo -> Bool -isLFThunk (LFThunk _ _ _ _ _) = True -isLFThunk LFBlackHole = True - -- return True for a blackhole: this function is used to determine - -- whether to use the thunk header in SMP mode, and a blackhole - -- must have one. -isLFThunk _ = False -\end{code} - -\begin{code} --- We keep the *zero-indexed* tag in the srt_len field of the info --- table of a data constructor. -type ConTagZ = Int -- A *zero-indexed* contructor tag - -dataConTagZ :: DataCon -> ConTagZ -dataConTagZ con = dataConTag con - fIRST_TAG -\end{code} - - -%************************************************************************ -%* * - Building ClosureInfos -%* * -%************************************************************************ - -\begin{code} -mkClosureInfo :: DynFlags - -> Bool -- Is static - -> Id - -> LambdaFormInfo - -> Int -> Int -- Total and pointer words - -> C_SRT - -> String -- String descriptor - -> ClosureInfo -mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr - = ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureSMRep = sm_rep, - closureSRT = srt_info, - closureType = idType id, - closureDescr = descr, - closureInfLcl = isDataConWorkId id } - -- Make the _info pointer for the implicit datacon worker binding - -- local. The reason we can do this is that importing code always - -- either uses the _closure or _con_info. By the invariants in CorePrep - -- anything else gets eta expanded. - where - name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) - nonptr_wds = tot_wds - ptr_wds - -mkConInfo :: DynFlags - -> Bool -- Is static - -> DataCon - -> Int -> Int -- Total and pointer words - -> ClosureInfo -mkConInfo dflags is_static data_con tot_wds ptr_wds - = ConInfo { closureSMRep = sm_rep, - closureCon = data_con } - where - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) - lf_info = mkConLFInfo data_con - nonptr_wds = tot_wds - ptr_wds -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}} -%* * -%************************************************************************ - -\begin{code} -closureSize :: DynFlags -> ClosureInfo -> WordOff -closureSize dflags cl_info = heapClosureSize dflags (closureSMRep cl_info) -\end{code} - -\begin{code} --- we leave space for an update if either (a) the closure is updatable --- or (b) it is a static thunk. This is because a static thunk needs --- a static link field in a predictable place (after the slop), regardless --- of whether it is updatable or not. -closureNeedsUpdSpace :: ClosureInfo -> Bool -closureNeedsUpdSpace (ClosureInfo { closureLFInfo = - LFThunk TopLevel _ _ _ _ }) = True -closureNeedsUpdSpace cl_info = closureUpdReqd cl_info -\end{code} - -%************************************************************************ -%* * -\subsection[SMreps]{Choosing SM reps} -%* * -%************************************************************************ - -\begin{code} -lfClosureType :: LambdaFormInfo -> ClosureTypeInfo -lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd -lfClosureType (LFCon con) = Constr (dataConTagZ con) - (dataConIdentity con) -lfClosureType (LFThunk _ _ _ is_sel _) = thunkClosureType is_sel -lfClosureType _ = panic "lfClosureType" - -thunkClosureType :: StandardFormInfo -> ClosureTypeInfo -thunkClosureType (SelectorThunk off) = ThunkSelector off -thunkClosureType _ = Thunk - --- We *do* get non-updatable top-level thunks sometimes. eg. f = g --- gets compiled to a jump to g (if g has non-zero arity), instead of --- messing around with update frames and PAPs. We set the closure type --- to FUN_STATIC in this case. -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@} -%* * -%************************************************************************ - -Be sure to see the stg-details notes about these... - -\begin{code} -nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool -nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) - = not no_fvs || -- Certainly if it has fvs we need to point to it - isNotTopLevel top - -- If it is not top level we will point to it - -- We can have a \r closure with no_fvs which - -- is not top level as special case cgRhsClosure - -- has been dissabled in favour of let floating - - -- For lex_profiling we also access the cost centre for a - -- non-inherited function i.e. not top level - -- the not top case above ensures this is ok. - -nodeMustPointToIt _ (LFCon _) = True - - -- Strictly speaking, the above two don't need Node to point - -- to it if the arity = 0. But this is a *really* unlikely - -- situation. If we know it's nil (say) and we are entering - -- it. Eg: let x = [] in x then we will certainly have inlined - -- x, since nil is a simple atom. So we gain little by not - -- having Node point to known zero-arity things. On the other - -- hand, we do lose something; Patrick's code for figuring out - -- when something has been updated but not entered relies on - -- having Node point to the result of an update. SLPJ - -- 27/11/92. - -nodeMustPointToIt dflags (LFThunk _ no_fvs updatable NonStandardThunk _) - = updatable || not no_fvs || gopt Opt_SccProfilingOn dflags - -- For the non-updatable (single-entry case): - -- - -- True if has fvs (in which case we need access to them, and we - -- should black-hole it) - -- or profiling (in which case we need to recover the cost centre - -- from inside it) - -nodeMustPointToIt _ (LFThunk _ _ _ _ _) - = True -- Node must point to any standard-form thunk - -nodeMustPointToIt _ (LFUnknown _) = True -nodeMustPointToIt _ LFBlackHole = True -- BH entry may require Node to point -nodeMustPointToIt _ (LFLetNoEscape _) = False -\end{code} - -The entry conventions depend on the type of closure being entered, -whether or not it has free variables, and whether we're running -sequentially or in parallel. - -\begin{tabular}{lllll} -Closure Characteristics & Parallel & Node Req'd & Argument Passing & Enter Via \\ -Unknown & no & yes & stack & node \\ -Known fun ($\ge$ 1 arg), no fvs & no & no & registers & fast entry (enough args) \\ -\ & \ & \ & \ & slow entry (otherwise) \\ -Known fun ($\ge$ 1 arg), fvs & no & yes & registers & fast entry (enough args) \\ -0 arg, no fvs @\r,\s@ & no & no & n/a & direct entry \\ -0 arg, no fvs @\u@ & no & yes & n/a & node \\ -0 arg, fvs @\r,\s@ & no & yes & n/a & direct entry \\ -0 arg, fvs @\u@ & no & yes & n/a & node \\ - -Unknown & yes & yes & stack & node \\ -Known fun ($\ge$ 1 arg), no fvs & yes & no & registers & fast entry (enough args) \\ -\ & \ & \ & \ & slow entry (otherwise) \\ -Known fun ($\ge$ 1 arg), fvs & yes & yes & registers & node \\ -0 arg, no fvs @\r,\s@ & yes & no & n/a & direct entry \\ -0 arg, no fvs @\u@ & yes & yes & n/a & node \\ -0 arg, fvs @\r,\s@ & yes & yes & n/a & node \\ -0 arg, fvs @\u@ & yes & yes & n/a & node\\ -\end{tabular} - -When black-holing, single-entry closures could also be entered via node -(rather than directly) to catch double-entry. - -\begin{code} -data CallMethod - = EnterIt -- no args, not a function - - | JumpToIt CLabel -- no args, not a function, but we - -- know what its entry code is - - | ReturnIt -- it's a function, but we have - -- zero args to apply to it, so just - -- return it. - - | ReturnCon DataCon -- It's a data constructor, just return it - - | SlowCall -- Unknown fun, or known fun with - -- too few args. - - | DirectEntry -- Jump directly, with args in regs - CLabel -- The code label - RepArity -- Its arity - -getCallMethod :: DynFlags - -> Name -- Function being applied - -> CafInfo -- Can it refer to CAF's? - -> LambdaFormInfo -- Its info - -> RepArity -- Number of available arguments - -> CallMethod - -getCallMethod dflags _ _ lf_info _ - | nodeMustPointToIt dflags lf_info && gopt Opt_Parallel dflags - = -- If we're parallel, then we must always enter via node. - -- The reason is that the closure may have been - -- fetched since we allocated it. - EnterIt - -getCallMethod dflags name caf (LFReEntrant _ arity _ _) n_args - | n_args == 0 = ASSERT( arity /= 0 ) - ReturnIt -- No args at all - | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel dflags name caf) arity - -getCallMethod dflags _ _ (LFCon con) n_args - -- when profiling, we must always enter a closure when we use it, so - -- that the closure can be recorded as used for LDV profiling. - | gopt Opt_SccProfilingOn dflags - = EnterIt - | otherwise - = ASSERT( n_args == 0 ) - ReturnCon con - -getCallMethod _dflags _name _caf (LFThunk _ _ _updatable _std_form_info is_fun) _n_args - | is_fun -- it *might* be a function, so we must "call" it (which is - -- always safe) - = SlowCall -- We cannot just enter it [in eval/apply, the entry code - -- is the fast-entry code] - - -- Since is_fun is False, we are *definitely* looking at a data value - | otherwise - = EnterIt - -- We used to have ASSERT( n_args == 0 ), but actually it is - -- possible for the optimiser to generate - -- let bot :: Int = error Int "urk" - -- in (bot `cast` unsafeCoerce Int (Int -> Int)) 3 - -- This happens as a result of the case-of-error transformation - -- So the right thing to do is just to enter the thing - --- Old version: --- | updatable || gopt Opt_Ticky dflags -- to catch double entry --- = EnterIt --- | otherwise -- Jump direct to code for single-entry thunks --- = JumpToIt (thunkEntryLabel name caf std_form_info updatable) --- --- Now we never use JumpToIt, even if the thunk is single-entry, since --- the thunk may have already been entered and blackholed by another --- processor. - - -getCallMethod _ _ _ (LFUnknown True) _ - = SlowCall -- Might be a function - -getCallMethod _ name _ (LFUnknown False) n_args - | n_args > 0 - = WARN( True, ppr name <+> ppr n_args ) - SlowCall -- Note [Unsafe coerce complications] - - | otherwise - = EnterIt -- Not a function - -getCallMethod _ _ _ LFBlackHole _ - = SlowCall -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we slow call it - -getCallMethod dflags name _ (LFLetNoEscape 0) _ - = JumpToIt (enterReturnPtLabel dflags (nameUnique name)) - -getCallMethod dflags name _ (LFLetNoEscape arity) n_args - | n_args == arity = DirectEntry (enterReturnPtLabel dflags (nameUnique name)) arity - | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) - - -blackHoleOnEntry :: ClosureInfo -> Bool -blackHoleOnEntry ConInfo{} = False -blackHoleOnEntry cl_info - | isStaticRep (closureSMRep cl_info) - = False -- Never black-hole a static closure - - | otherwise - = case closureLFInfo cl_info of - LFReEntrant _ _ _ _ -> False - LFLetNoEscape _ -> False - LFThunk _ _no_fvs _updatable _ _ -> True - _other -> panic "blackHoleOnEntry" -- Should never happen - -isKnownFun :: LambdaFormInfo -> Bool -isKnownFun (LFReEntrant _ _ _ _) = True -isKnownFun (LFLetNoEscape _) = True -isKnownFun _ = False -\end{code} - -Note [Unsafe coerce complications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some (badly-optimised) DPH code we see this - Module X: rr :: Int = error Int "Urk" - Module Y: ...((X.rr |> g) True) ... - where g is an (unsafe) coercion of kind (Int ~ Bool->Bool), say - -It's badly optimised, because knowing that 'X.rr' is bottom, we should -have dumped the application to True. But it should still work. These -strange unsafe coercions arise from the case-of-error transformation: - (case (error Int "foo") of { ... }) True ----> (error Int "foo" |> g) True - -Anyway, the net effect is that in STG-land, when casts are discarded, -we *can* see a value of type Int applied to an argument. This only happens -if (a) the programmer made a mistake, or (b) the value of type Int is -actually bottom. - -So it's wrong to trigger an ASSERT failure in this circumstance. Instead -we now emit a WARN -- mainly to draw attention to a probably-badly-optimised -program fragment -- and do the conservative thing which is SlowCall. - - ------------------------------------------------------------------------------ -SRT-related stuff - -\begin{code} -staticClosureNeedsLink :: ClosureInfo -> Bool --- A static closure needs a link field to aid the GC when traversing --- the static closure graph. But it only needs such a field if either --- a) it has an SRT --- b) it's a constructor with one or more pointer fields --- In case (b), the constructor's fields themselves play the role --- of the SRT. -staticClosureNeedsLink (ClosureInfo { closureSRT = srt }) - = needsSRT srt -staticClosureNeedsLink (ConInfo { closureSMRep = rep }) - = not (isStaticNoCafCon rep) -\end{code} - -Note [Entering error thunks] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this - - fail :: Int - fail = error Int "Urk" - - foo :: Bool -> Bool - foo True y = (fail `cast` Bool -> Bool) y - foo False y = False - -This looks silly, but it can arise from case-of-error. Even if it -does, we'd usually see that 'fail' is a bottoming function and would -discard the extra argument 'y'. But even if that does not occur, -this program is still OK. We will enter 'fail', which never returns. - -The WARN is just to alert me to the fact that we aren't spotting that -'fail' is bottoming. - -(We are careful never to make a funtion value look like a data type, -because we can't enter a function closure -- but that is not the -problem here.) - - -Avoiding generating entries and info tables -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At present, for every function we generate all of the following, -just in case. But they aren't always all needed, as noted below: - -[NB1: all of this applies only to *functions*. Thunks always -have closure, info table, and entry code.] - -[NB2: All are needed if the function is *exported*, just to play safe.] - - -* Fast-entry code ALWAYS NEEDED - -* Slow-entry code - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) we're in the parallel world and the function has free vars - [Reason: in parallel world, we always enter functions - with free vars via the closure.] - -* The function closure - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) if the function has free vars (ie not top level) - - Why case (a) here? Because if the arg-satis check fails, - UpdatePAP stuffs a pointer to the function closure in the PAP. - [Could be changed; UpdatePAP could stuff in a code ptr instead, - but doesn't seem worth it.] - - [NB: these conditions imply that we might need the closure - without the slow-entry code. Here's how. - - f x y = let g w = ...x..y..w... - in - ...(g t)... - - Here we need a closure for g which contains x and y, - but since the calls are all saturated we just jump to the - fast entry point for g, with R1 pointing to the closure for g.] - - -* Standard info table - Needed iff (a) we have any un-saturated calls to the function - OR (b) the function is passed as an arg - OR (c) the function has free vars (ie not top level) - - NB. In the sequential world, (c) is only required so that the function closure has - an info table to point to, to keep the storage manager happy. - If (c) alone is true we could fake up an info table by choosing - one of a standard family of info tables, whose entry code just - bombs out. - - [NB In the parallel world (c) is needed regardless because - we enter functions with free vars via the closure.] - - If (c) is retained, then we'll sometimes generate an info table - (for storage mgr purposes) without slow-entry code. Then we need - to use an error label in the info table to substitute for the absent - slow entry code. - -\begin{code} -staticClosureRequired - :: Name - -> StgBinderInfo - -> LambdaFormInfo - -> Bool -staticClosureRequired _ bndr_info - (LFReEntrant top_level _ _ _) -- It's a function - = ASSERT( isTopLevel top_level ) - -- Assumption: it's a top-level, no-free-var binding - not (satCallsOnly bndr_info) - -staticClosureRequired _ _ _ = True -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.} -%* * -%************************************************************************ - -\begin{code} -isStaticClosure :: ClosureInfo -> Bool -isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) - -closureUpdReqd :: ClosureInfo -> Bool -closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info -closureUpdReqd ConInfo{} = False - -lfUpdatable :: LambdaFormInfo -> Bool -lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable LFBlackHole = True - -- Black-hole closures are allocated to receive the results of an - -- alg case with a named default... so they need to be updated. -lfUpdatable _ = False - -closureIsThunk :: ClosureInfo -> Bool -closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info -closureIsThunk ConInfo{} = False - -closureSingleEntry :: ClosureInfo -> Bool -closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd -closureSingleEntry _ = False - -closureReEntrant :: ClosureInfo -> Bool -closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True -closureReEntrant _ = False - -isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon -isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con -isConstrClosure_maybe _ = Nothing - -closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr) -closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info -closureFunInfo _ = Nothing - -lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) -lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) -lfFunInfo _ = Nothing - -funTag :: DynFlags -> ClosureInfo -> Int -funTag dflags (ClosureInfo { closureLFInfo = lf_info }) - = funTagLFInfo dflags lf_info -funTag _ _ = 0 - --- maybe this should do constructor tags too? -funTagLFInfo :: DynFlags -> LambdaFormInfo -> Int -funTagLFInfo dflags lf - -- A function is tagged with its arity - | Just (arity,_) <- lfFunInfo lf, - Just tag <- tagForArity dflags arity - = tag - - -- other closures (and unknown ones) are not tagged - | otherwise - = 0 - -tagForArity :: DynFlags -> RepArity -> Maybe Int -tagForArity dflags i - | i <= mAX_PTR_TAG dflags = Just i - | otherwise = Nothing - -clHasCafRefs :: ClosureInfo -> CafInfo -clHasCafRefs (ClosureInfo {closureSRT = srt}) = - case srt of NoC_SRT -> NoCafRefs - _ -> MayHaveCafRefs -clHasCafRefs (ConInfo {}) = NoCafRefs -\end{code} - -\begin{code} -isToplevClosure :: ClosureInfo -> Bool -isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) - = case lf_info of - LFReEntrant TopLevel _ _ _ -> True - LFThunk TopLevel _ _ _ _ -> True - _ -> False -isToplevClosure _ = False -\end{code} - -Label generation. - -\begin{code} -infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI = fst . labelsFromCI - -entryLabelFromCI :: DynFlags -> ClosureInfo -> CLabel -entryLabelFromCI dflags ci - | tablesNextToCode dflags = info_lbl - | otherwise = entry_lbl - where (info_lbl, entry_lbl) = labelsFromCI ci - -labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) -labelsFromCI cl@(ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureInfLcl = is_lcl }) - = case lf_info of - LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) - - LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset - - LFThunk _ _ upd_flag (ApThunk arity) _ -> - bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - - LFThunk{} -> bothL std_mk_lbls name $ clHasCafRefs cl - - LFReEntrant _ _ _ _ -> bothL std_mk_lbls name $ clHasCafRefs cl - - _ -> panic "labelsFromCI" - where std_mk_lbls = if is_lcl then (mkLocalInfoTableLabel, mkLocalEntryLabel) else (mkInfoTableLabel, mkEntryLabel) - -labelsFromCI cl@(ConInfo { closureCon = con, - closureSMRep = rep }) - | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl - | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl - where - name = dataConName con - -bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) -bothL (f, g) x y = (f x y, g x y) - --- ClosureInfo for a closure (as opposed to a constructor) is always local -closureLabelFromCI :: ClosureInfo -> CLabel -closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm $ clHasCafRefs cl -closureLabelFromCI _ = panic "closureLabelFromCI" - --- thunkEntryLabel is a local help function, not exported. It's used from both --- entryLabelFromCI and getCallMethod. - -{- UNUSED: -thunkEntryLabel :: Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel -thunkEntryLabel _thunk_id _ (ApThunk arity) is_updatable - = enterApLabel is_updatable arity -thunkEntryLabel _thunk_id _ (SelectorThunk offset) upd_flag - = enterSelectorLabel upd_flag offset -thunkEntryLabel thunk_id caf _ _is_updatable - = enterIdLabel thunk_id caf --} - -{- UNUSED: -enterApLabel :: Bool -> Int -> CLabel -enterApLabel is_updatable arity - | tablesNextToCode = mkApInfoTableLabel is_updatable arity - | otherwise = mkApEntryLabel is_updatable arity --} - -{- UNUSED: -enterSelectorLabel :: Bool -> Int -> CLabel -enterSelectorLabel upd_flag offset - | tablesNextToCode = mkSelectorInfoLabel upd_flag offset - | otherwise = mkSelectorEntryLabel upd_flag offset --} - -enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel -enterIdLabel dflags id - | tablesNextToCode dflags = mkInfoTableLabel id - | otherwise = mkEntryLabel id - -enterReturnPtLabel :: DynFlags -> Unique -> CLabel -enterReturnPtLabel dflags name - | tablesNextToCode dflags = mkReturnInfoLabel name - | otherwise = mkReturnPtLabel name -\end{code} - - -We need a black-hole closure info to pass to @allocDynClosure@ when we -want to allocate the black hole on entry to a CAF. These are the only -ways to build an LFBlackHole, maintaining the invariant that it really -is a black hole and not something else. - -\begin{code} -cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo -cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) - = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole, - closureSMRep = blackHoleRep, - closureSRT = NoC_SRT, - closureType = ty, - closureDescr = "", - closureInfLcl = False } -cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" -\end{code} - -%************************************************************************ -%* * -\subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.} -%* * -%************************************************************************ - -Profiling requires two pieces of information to be determined for -each closure's info table --- description and type. - -The description is stored directly in the @CClosureInfoTable@ when the -info table is built. - -The type is determined from the type information stored with the @Id@ -in the closure info using @closureTypeDescr@. - -\begin{code} -closureValDescr, closureTypeDescr :: ClosureInfo -> String -closureValDescr (ClosureInfo {closureDescr = descr}) - = descr -closureValDescr (ConInfo {closureCon = con}) - = occNameString (getOccName con) - -closureTypeDescr (ClosureInfo { closureType = ty }) - = getTyDescription ty -closureTypeDescr (ConInfo { closureCon = data_con }) - = occNameString (getOccName (dataConTyCon data_con)) - -getTyDescription :: Type -> String -getTyDescription ty - = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) -> - case tau_ty of - TyVarTy _ -> "*" - AppTy fun _ -> getTyDescription fun - FunTy _ res -> '-' : '>' : fun_result res - TyConApp tycon _ -> getOccString tycon - ForAllTy _ ty -> getTyDescription ty - LitTy n -> getTyLitDescription n - } - where - fun_result (FunTy _ res) = '>' : fun_result res - fun_result other = getTyDescription other - - -getTyLitDescription :: TyLit -> String -getTyLitDescription l = - case l of - NumTyLit n -> show n - StrTyLit n -> show n -\end{code} diff --git a/compiler/codeGen/ClosureInfo.lhs-boot b/compiler/codeGen/ClosureInfo.lhs-boot deleted file mode 100644 index b069905d3e..0000000000 --- a/compiler/codeGen/ClosureInfo.lhs-boot +++ /dev/null @@ -1,6 +0,0 @@ -\begin{code} -module ClosureInfo where - -data LambdaFormInfo -data ClosureInfo -\end{code}
\ No newline at end of file diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs index fe00d7c384..91b0c8ba04 100644 --- a/compiler/codeGen/StgCmmGran.hs +++ b/compiler/codeGen/StgCmmGran.hs @@ -96,7 +96,7 @@ reschedule liveness node_reqd = panic "granReschedule" -- @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 +-- \item Slow entry code where node is not alive (see @StgCmmClosure.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 diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 87793ab20f..39676635aa 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -30,7 +30,9 @@ module StgCmmLayout ( cmmGetClosureType, infoTable, infoTableClosureType, infoTablePtrs, infoTableNonPtrs, - funInfoTable + funInfoTable, + + ArgRep(..), toArgRep, argRepSizeW ) where @@ -329,15 +331,15 @@ slowCallPattern [] = (fsLit "stg_ap_0", 0) -- Classifying arguments: ArgRep ------------------------------------------------------------------------- --- ArgRep is not exported (even abstractly) --- It's a local helper type for classification +-- ArgRep is exported, but only for use in the byte-code generator which +-- also needs to know about the classification of arguments. -data ArgRep = P -- GC Ptr - | N -- One-word non-ptr - | L -- Two-word non-ptr (long) - | V -- Void - | F -- Float - | D -- Double +data ArgRep = P -- GC Ptr + | N -- Word-sized non-ptr + | L -- 64-bit non-ptr (long) + | V -- Void + | F -- Float + | D -- Double instance Outputable ArgRep where ppr P = text "P" ppr N = text "N" diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 888ff1a0be..1a10cd162e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -208,24 +208,6 @@ Library CodeGen.Platform.SPARC CodeGen.Platform.X86 CodeGen.Platform.X86_64 - CgBindery - CgCallConv - CgCase - CgClosure - CgCon - CgExpr - CgForeignCall - CgHeapery - CgHpc - CgInfoTbls - CgLetNoEscape - CgMonad - CgParallel - CgPrimOp - CgProf - CgStackery - CgTailCall - CgTicky CgUtils StgCmm StgCmmBind @@ -244,7 +226,6 @@ Library StgCmmTicky StgCmmUtils StgCmmExtCode - ClosureInfo SMRep CoreArity CoreFVs @@ -482,6 +463,9 @@ Library Hoopl.Dataflow Hoopl +-- CgInfoTbls used in ghci/DebuggerUtils +-- CgHeapery mkVirtHeapOffsets used in ghci + Exposed-Modules: AsmCodeGen TargetReg diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index f00e45c6b6..4ff09eff66 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -28,8 +28,8 @@ import Literal import TyCon import PrimOp import FastString +import StgCmmLayout ( ArgRep(..) ) import SMRep -import ClosureInfo -- CgRep stuff import DynFlags import Outputable import Platform @@ -440,21 +440,21 @@ assembleI dflags i = case i of isLarge :: Word -> Bool isLarge n = n > 65535 -push_alts :: CgRep -> Word16 -push_alts NonPtrArg = bci_PUSH_ALTS_N -push_alts FloatArg = bci_PUSH_ALTS_F -push_alts DoubleArg = bci_PUSH_ALTS_D -push_alts VoidArg = bci_PUSH_ALTS_V -push_alts LongArg = bci_PUSH_ALTS_L -push_alts PtrArg = bci_PUSH_ALTS_P - -return_ubx :: CgRep -> Word16 -return_ubx NonPtrArg = bci_RETURN_N -return_ubx FloatArg = bci_RETURN_F -return_ubx DoubleArg = bci_RETURN_D -return_ubx VoidArg = bci_RETURN_V -return_ubx LongArg = bci_RETURN_L -return_ubx PtrArg = bci_RETURN_P +push_alts :: ArgRep -> Word16 +push_alts V = bci_PUSH_ALTS_V +push_alts P = bci_PUSH_ALTS_P +push_alts N = bci_PUSH_ALTS_N +push_alts L = bci_PUSH_ALTS_L +push_alts F = bci_PUSH_ALTS_F +push_alts D = bci_PUSH_ALTS_D + +return_ubx :: ArgRep -> Word16 +return_ubx V = bci_RETURN_V +return_ubx P = bci_RETURN_P +return_ubx N = bci_RETURN_N +return_ubx L = bci_RETURN_L +return_ubx F = bci_RETURN_F +return_ubx D = bci_RETURN_D -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index af7a06876d..bd636c9b77 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -46,8 +46,8 @@ import ErrUtils import Unique import FastString import Panic +import StgCmmLayout ( ArgRep(..), toArgRep, argRepSizeW ) import SMRep -import ClosureInfo import Bitmap import OrdList @@ -145,7 +145,7 @@ ppBCEnv p $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p)))) $$ text "end-env" where - pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var) + pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var) cmp_snd x y = compare (snd x) (snd y) -} @@ -207,11 +207,11 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallo peep [] = [] -argBits :: DynFlags -> [CgRep] -> [Bool] +argBits :: DynFlags -> [ArgRep] -> [Bool] argBits _ [] = [] argBits dflags (rep : args) - | isFollowableArg rep = False : argBits dflags args - | otherwise = take (cgRepSizeW dflags rep) (repeat True) ++ argBits dflags args + | isFollowableArg rep = False : argBits dflags args + | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args -- ----------------------------------------------------------------------------- -- schemeTopBind @@ -297,7 +297,7 @@ schemeR_wrk fvs nm original_body (args, body) p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) -- make the arg bitmap - bits = argBits dflags (reverse (map idCgRep all_args)) + bits = argBits dflags (reverse (map bcIdArgRep all_args)) bitmap_size = genericLength bits bitmap = mkBitmap dflags bits body_code <- schemeER_wrk szw_args p_init body @@ -358,7 +358,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs, -- schemeE returnUnboxedAtom :: Word -> Sequel -> BCEnv - -> AnnExpr' Id VarSet -> CgRep + -> AnnExpr' Id VarSet -> ArgRep -> BcM BCInstrList -- Returning an unlifted value. -- Heave it on the stack, SLIDE, and RETURN. @@ -379,11 +379,11 @@ schemeE d s p e -- Delegate tail-calls to schemeT. schemeE d s p e@(AnnApp _ _) = schemeT d s p e -schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeCgRep (literalType lit)) -schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e VoidArg +schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeArgRep (literalType lit)) +schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V schemeE d s p e@(AnnVar v) - | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdCgRep v) + | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v) | otherwise = schemeT d s p e schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) @@ -495,7 +495,7 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2) -- Convert - -- case .... of x { (# VoidArg'd-thing, a #) -> ... } + -- case .... of x { (# V'd-thing, a #) -> ... } -- to -- case .... of a { DEFAULT -> ... } -- becuse the return convention for both are identical. @@ -569,9 +569,9 @@ schemeE _ _ _ expr -- -- 1. The fn denotes a ccall. Defer to generateCCall. -- --- 2. (Another nasty hack). Spot (# a::VoidArg, b #) and treat +-- 2. (Another nasty hack). Spot (# a::V, b #) and treat -- it simply as b -- since the representations are identical --- (the VoidArg takes up zero stack space). Also, spot +-- (the V takes up zero stack space). Also, spot -- (# b #) and treat it as b. -- -- 3. Application of a constructor, by defn saturated. @@ -611,9 +611,9 @@ schemeT d s p app | Just con <- maybe_saturated_dcon, isUnboxedTupleCon con = case args_r_to_l of - [arg1,arg2] | isVoidArgAtom arg1 -> + [arg1,arg2] | isVAtom arg1 -> unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVoidArgAtom arg2 -> + [arg1,arg2] | isVAtom arg2 -> unboxedTupleReturn d s p arg1 _other -> unboxedTupleException @@ -738,28 +738,28 @@ doTailCall init_d s p fn args return (final_d, push_code `appOL` more_push_code) -- v. similar to CgStackery.findMatch, ToDo: merge -findPushSeq :: [CgRep] -> (BCInstr, Int, [CgRep]) -findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) +findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) +findPushSeq (P: P: P: P: P: P: rest) = (PUSH_APPLY_PPPPPP, 6, rest) -findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest) +findPushSeq (P: P: P: P: P: rest) = (PUSH_APPLY_PPPPP, 5, rest) -findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest) +findPushSeq (P: P: P: P: rest) = (PUSH_APPLY_PPPP, 4, rest) -findPushSeq (PtrArg: PtrArg: PtrArg: rest) +findPushSeq (P: P: P: rest) = (PUSH_APPLY_PPP, 3, rest) -findPushSeq (PtrArg: PtrArg: rest) +findPushSeq (P: P: rest) = (PUSH_APPLY_PP, 2, rest) -findPushSeq (PtrArg: rest) +findPushSeq (P: rest) = (PUSH_APPLY_P, 1, rest) -findPushSeq (VoidArg: rest) +findPushSeq (V: rest) = (PUSH_APPLY_V, 1, rest) -findPushSeq (NonPtrArg: rest) +findPushSeq (N: rest) = (PUSH_APPLY_N, 1, rest) -findPushSeq (FloatArg: rest) +findPushSeq (F: rest) = (PUSH_APPLY_F, 1, rest) -findPushSeq (DoubleArg: rest) +findPushSeq (D: rest) = (PUSH_APPLY_D, 1, rest) -findPushSeq (LongArg: rest) +findPushSeq (L: rest) = (PUSH_APPLY_L, 1, rest) findPushSeq _ = panic "ByteCodeGen.findPushSeq" @@ -825,7 +825,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- algebraic alt with some binders | otherwise = let - (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs + (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs ptr_sizes = map (fromIntegral . idSizeW dflags) ptrs nptrs_sizes = map (fromIntegral . idSizeW dflags) nptrs bind_sizes = ptr_sizes ++ nptrs_sizes @@ -887,7 +887,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- NB: unboxed tuple cases bind the scrut binder to the same offset -- as one of the alt binders, so we have to remove any duplicates here: rel_slots = nub $ map fromIntegral $ concat (map spread binds) - spread (id, offset) | isFollowableArg (bcIdCgRep id) = [ rel_offset ] + spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ] | otherwise = [] where rel_offset = trunc16 $ d - fromIntegral offset - 1 @@ -906,7 +906,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple alt_bco' <- emitBc alt_bco let push_alts | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty) return (push_alts `consOL` scrut_code) @@ -933,12 +933,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l let -- useful constants addr_sizeW :: Word16 - addr_sizeW = fromIntegral (cgRepSizeW dflags NonPtrArg) + addr_sizeW = fromIntegral (argRepSizeW dflags N) -- Get the args on the stack, with tags and suitably -- dereferenced for the CCall. For each arg, return the -- depth to the first word of the bits for that arg, and the - -- CgRep of what was actually pushed. + -- ArgRep of what was actually pushed. pargs _ [] = return [] pargs d (a:az) @@ -1071,7 +1071,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, - -- this is a VoidArg (tag). + -- this is a V (tag). r_sizeW = fromIntegral (primRepSizeW dflags r_rep) d_after_r = d_after_Addr + fromIntegral r_sizeW r_lit = mkDummyLiteral r_rep @@ -1100,8 +1100,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l (fromIntegral (fromEnum (playInterruptible safety)))) -- slide and return wrapup = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s) - `snocOL` RETURN_UBX (primRepToCgRep r_rep) - --trace (show (arg1_offW, args_offW , (map cgRepSizeW a_reps) )) $ + `snocOL` RETURN_UBX (toArgRep r_rep) + --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $ return ( push_args `appOL` push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup @@ -1127,7 +1127,7 @@ mkDummyLiteral pr -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- -- to Just IntRep --- and check that an unboxed pair is returned wherein the first arg is VoidArg'd. +-- and check that an unboxed pair is returned wherein the first arg is V'd. -- -- Alternatively, for call-targets returning nothing, convert -- @@ -1203,11 +1203,11 @@ pushAtom d p e = pushAtom d p e' pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, - = return (nilOL, 0) -- treated just like a variable VoidArg + = return (nilOL, 0) -- treated just like a variable V pushAtom d p (AnnVar v) | UnaryRep rep_ty <- repType (idType v) - , VoidArg <- typeCgRep rep_ty + , V <- typeArgRep rep_ty = return (nilOL, 0) | isFCallId v @@ -1244,20 +1244,20 @@ pushAtom d p (AnnVar v) pushAtom _ _ (AnnLit lit) = do dflags <- getDynFlags let code rep - = let size_host_words = fromIntegral (cgRepSizeW dflags rep) + = let size_host_words = fromIntegral (argRepSizeW dflags rep) in return (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) case lit of - MachLabel _ _ _ -> code NonPtrArg - MachWord _ -> code NonPtrArg - MachInt _ -> code NonPtrArg - MachWord64 _ -> code LongArg - MachInt64 _ -> code LongArg - MachFloat _ -> code FloatArg - MachDouble _ -> code DoubleArg - MachChar _ -> code NonPtrArg - MachNullAddr -> code NonPtrArg + MachLabel _ _ _ -> code N + MachWord _ -> code N + MachInt _ -> code N + MachWord64 _ -> code L + MachInt64 _ -> code L + MachFloat _ -> code F + MachDouble _ -> code D + MachChar _ -> code N + MachNullAddr -> code N MachStr s -> pushStr s -- No LitInteger's should be left by the time this is called. -- CorePrep should have converted them all to a real core @@ -1437,14 +1437,22 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word lookupBCEnv_maybe = Map.lookup idSizeW :: DynFlags -> Id -> Int -idSizeW dflags = cgRepSizeW dflags . bcIdCgRep +idSizeW dflags = argRepSizeW dflags . bcIdArgRep -bcIdCgRep :: Id -> CgRep -bcIdCgRep = primRepToCgRep . bcIdPrimRep +bcIdArgRep :: Id -> ArgRep +bcIdArgRep = toArgRep . bcIdPrimRep bcIdPrimRep :: Id -> PrimRep bcIdPrimRep = typePrimRep . bcIdUnaryType +isFollowableArg :: ArgRep -> Bool +isFollowableArg P = True +isFollowableArg _ = False + +isVoidArg :: ArgRep -> Bool +isVoidArg V = True +isVoidArg _ = False + bcIdUnaryType :: Id -> UnaryType bcIdUnaryType x = case repType (idType x) of UnaryRep rep_ty -> rep_ty @@ -1501,11 +1509,11 @@ bcView (AnnTick Breakpoint{} _) = Nothing bcView (AnnTick _other_tick (_,e)) = Just e bcView _ = Nothing -isVoidArgAtom :: AnnExpr' Var ann -> Bool -isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e' -isVoidArgAtom (AnnVar v) = bcIdCgRep v == VoidArg -isVoidArgAtom (AnnCoercion {}) = True -isVoidArgAtom _ = False +isVAtom :: AnnExpr' Var ann -> Bool +isVAtom e | Just e' <- bcView e = isVAtom e' +isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v) +isVAtom (AnnCoercion {}) = True +isVAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' @@ -1514,11 +1522,11 @@ atomPrimRep (AnnLit l) = typePrimRep (literalType l) atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) -atomRep :: AnnExpr' Id ann -> CgRep -atomRep e = primRepToCgRep (atomPrimRep e) +atomRep :: AnnExpr' Id ann -> ArgRep +atomRep e = toArgRep (atomPrimRep e) isPtrAtom :: AnnExpr' Id ann -> Bool -isPtrAtom e = atomRep e == PtrArg +isPtrAtom e = isFollowableArg (atomRep e) -- Let szsw be the sizes in words of some items pushed onto the stack, -- which has initial depth d'. Return the values which the stack environment @@ -1527,6 +1535,9 @@ mkStackOffsets :: Word -> [Word] -> [Word] mkStackOffsets original_depth szsw = map (subtract 1) (tail (scanl (+) original_depth szsw)) +typeArgRep :: Type -> ArgRep +typeArgRep = toArgRep . typePrimRep + -- ----------------------------------------------------------------------------- -- The bytecode generator's monad diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs index ed49960709..7fc84ae214 100644 --- a/compiler/ghci/ByteCodeInstr.lhs +++ b/compiler/ghci/ByteCodeInstr.lhs @@ -22,6 +22,7 @@ module ByteCodeInstr ( import ByteCodeItbls ( ItblPtr ) +import StgCmmLayout ( ArgRep(..) ) import PprCore import Type import Outputable @@ -34,7 +35,6 @@ import DataCon import VarSet import PrimOp import SMRep -import ClosureInfo -- CgRep stuff import Module (Module) import GHC.Exts @@ -75,7 +75,7 @@ data BCInstr -- Push an alt continuation | PUSH_ALTS (ProtoBCO Name) - | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep + | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep -- Pushing literals | PUSH_UBX (Either Literal (Ptr ())) Word16 @@ -147,7 +147,7 @@ data BCInstr -- To Infinity And Beyond | ENTER | RETURN -- return a lifted value - | RETURN_UBX CgRep -- return an unlifted value, here's its rep + | RETURN_UBX ArgRep -- return an unlifted value, here's its rep -- Breakpoints | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo diff --git a/compiler/ghci/ByteCodeItbls.lhs b/compiler/ghci/ByteCodeItbls.lhs index 2564d4b797..79c88fd1df 100644 --- a/compiler/ghci/ByteCodeItbls.lhs +++ b/compiler/ghci/ByteCodeItbls.lhs @@ -23,11 +23,10 @@ module ByteCodeItbls ( ItblEnv, ItblPtr(..), itblCode, mkITbls import DynFlags import Name ( Name, getName ) import NameEnv -import ClosureInfo import DataCon ( DataCon, dataConRepArgTys, dataConIdentity ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) -import Type ( flattenRepType, repType ) -import CgHeapery ( mkVirtHeapOffsets ) +import Type ( flattenRepType, repType, typePrimRep ) +import StgCmmLayout ( mkVirtHeapOffsets ) import Util import Foreign @@ -99,7 +98,7 @@ make_constr_itbls dflags cons mk_itbl :: DataCon -> Int -> Ptr () -> IO (Name,ItblPtr) mk_itbl dcon conNo entry_addr = do - let rep_args = [ (typeCgRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ] + let rep_args = [ (typePrimRep rep_arg,rep_arg) | arg <- dataConRepArgTys dcon, rep_arg <- flattenRepType (repType arg) ] (tot_wds, ptr_wds, _) = mkVirtHeapOffsets dflags False{-not a THUNK-} rep_args ptrs' = ptr_wds diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index b1688d85f8..8a421baf6b 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -2,13 +2,13 @@ module DebuggerUtils ( dataConInfoPtrToName, ) where +import StgCmmLayout ( stdInfoTableSizeB ) import ByteCodeItbls import DynFlags import FastString import TcRnTypes import TcRnMonad import IfaceEnv -import CgInfoTbls import Module import OccName import Name diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 5b944b799d..86fab77ad9 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -30,7 +30,7 @@ import Llvm import LlvmCodeGen.Regs import CLabel -import CgUtils ( activeStgRegs ) +import CodeGen.Platform ( activeStgRegs ) import DynFlags import FastString import OldCmm diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 30786b6895..73cd98f63a 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -12,7 +12,7 @@ import LlvmCodeGen.Base import LlvmCodeGen.Regs import BlockId -import CgUtils ( activeStgRegs, callerSaves ) +import CodeGen.Platform ( activeStgRegs, callerSaves ) import CLabel import OldCmm import qualified OldPprCmm as PprCmm |