Commit b8bfab80 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org/ghc

parents c548f91f 713cf473
......@@ -65,7 +65,7 @@ module Id (
hasNoBinding,
-- ** Evidence variables
DictId, isDictId, isEvVar,
DictId, isDictId, dfunNSilent, isEvVar,
-- ** Inline pragma stuff
idInlinePragma, setInlinePragma, modifyInlinePragma,
......@@ -118,7 +118,7 @@ import Demand
import Name
import Module
import Class
import PrimOp
import {-# SOURCE #-} PrimOp (PrimOp)
import ForeignCall
import Maybes
import SrcLoc
......@@ -342,6 +342,11 @@ isDFunId id = case Var.idDetails id of
DFunId {} -> True
_ -> False
dfunNSilent :: Id -> Int
dfunNSilent id = case Var.idDetails id of
DFunId ns _ -> ns
_ -> pprPanic "dfunSilent: not a dfun:" (ppr id)
isPrimOpId_maybe id = case Var.idDetails id of
PrimOpId op -> Just op
_ -> Nothing
......
......@@ -75,7 +75,7 @@ module IdInfo (
import CoreSyn
import Class
import PrimOp
import {-# SOURCE #-} PrimOp (PrimOp)
import Name
import VarSet
import BasicTypes
......@@ -136,7 +136,14 @@ data IdDetails
| TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary)
| DFunId Bool -- ^ A dictionary function.
| DFunId Int Bool -- ^ A dictionary function.
-- Int = the number of "silent" arguments to the dfun
-- e.g. class D a => C a where ...
-- instance C a => C [a]
-- has is_silent = 1, because the dfun
-- has type dfun :: (D a, C a) => C [a]
-- See the DFun Superclass Invariant in TcInstDcls
--
-- Bool = True <=> the class has only one method, so may be
-- implemented with a newtype, so it might be bad
-- to be strict on this dictionary
......@@ -158,7 +165,8 @@ pprIdDetails other = brackets (pp other)
pp (PrimOpId _) = ptext (sLit "PrimOp")
pp (FCallId _) = ptext (sLit "ForeignCall")
pp (TickBoxOpId _) = ptext (sLit "TickBoxOp")
pp (DFunId nt) = ptext (sLit "DFunId")
pp (DFunId ns nt) = ptext (sLit "DFunId")
<> ppWhen (ns /= 0) (brackets (int ns))
<> ppWhen nt (ptext (sLit "(nt)"))
pp (RecSelId { sel_naughty = is_naughty })
= brackets $ ptext (sLit "RecSel")
......
......@@ -826,17 +826,29 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-- Implements the DFun Superclass Invariant (see TcInstDcls)
mkDictFunId dfun_name tvs theta clas tys
= mkExportedLocalVar (DFunId is_nt)
= mkExportedLocalVar (DFunId n_silent is_nt)
dfun_name
dfun_ty
vanillaIdInfo
where
is_nt = isNewTyCon (classTyCon clas)
dfun_ty = mkDictFunTy tvs theta clas tys
(n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type)
mkDictFunTy tvs theta clas tys
= mkSigmaTy tvs theta (mkClassPred clas tys)
= (length silent_theta, dfun_ty)
where
dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkClassPred clas tys)
silent_theta
| null tvs, null theta
= []
| otherwise
= filterOut discard $
substTheta (zipTopTvSubst (classTyVars clas) tys)
(classSCTheta clas)
-- See Note [Silent Superclass Arguments]
discard pred = any (`eqPred` pred) theta
-- See the DFun Superclass Invariant in TcInstDcls
\end{code}
......
......@@ -2,8 +2,11 @@
module MkId where
import Name( Name )
import DataCon( DataCon, DataConIds )
import {-# SOURCE #-} PrimOp( PrimOp )
import Id( Id )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkPrimOpId :: PrimOp -> Id
\end{code}
......@@ -82,6 +82,8 @@ import FastString
import Data.Bits
import Data.Data
import Data.List
import Data.Ord
import System.FilePath
\end{code}
......@@ -176,9 +178,7 @@ instance Ord RealSrcLoc where
compare = cmpRealSrcLoc
sortLocated :: [Located a] -> [Located a]
sortLocated things = sortLe le things
where
le (L l1 _) (L l2 _) = l1 <= l2
sortLocated things = sortBy (comparing getLoc) things
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
......
......@@ -109,7 +109,7 @@ takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily (iBox n), s1)
\begin{code}
-- | A monad which just gives the ability to obtain 'Unique's
newtype UniqSM result = USM { unUSM :: UniqSupply -> (result, UniqSupply) }
newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) }
instance Monad UniqSM where
return = returnUs
......@@ -118,21 +118,21 @@ instance Monad UniqSM where
instance Functor UniqSM where
fmap f (USM x) = USM (\us -> case x us of
(r, us') -> (f r, us'))
(# r, us' #) -> (# f r, us' #))
instance Applicative UniqSM where
pure = returnUs
(USM f) <*> (USM x) = USM $ \us -> case f us of
(ff, us') -> case x us' of
(xx, us'') -> (ff xx, us'')
(# ff, us' #) -> case x us' of
(# xx, us'' #) -> (# ff xx, us'' #)
-- | Run the 'UniqSM' action, returning the final 'UniqSupply'
initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply)
initUs init_us m = case unUSM m init_us of { (r,us) -> (r,us) }
initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) }
-- | Run the 'UniqSM' action, discarding the final 'UniqSupply'
initUs_ :: UniqSupply -> UniqSM a -> a
initUs_ init_us m = case unUSM m init_us of { (r, _) -> r }
initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r }
{-# INLINE thenUs #-}
{-# INLINE lazyThenUs #-}
......@@ -142,27 +142,30 @@ initUs_ init_us m = case unUSM m init_us of { (r, _) -> r }
@thenUs@ is where we split the @UniqSupply@.
\begin{code}
liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply)
liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us')
instance MonadFix UniqSM where
mfix m = USM (\us -> let (r,us') = unUSM (m r) us in (r,us'))
mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #))
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs (USM expr) cont
= USM (\us -> case (expr us) of
(result, us') -> unUSM (cont result) us')
(# result, us' #) -> unUSM (cont result) us')
lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
lazyThenUs (USM expr) cont
= USM (\us -> let (result, us') = expr us in unUSM (cont result) us')
lazyThenUs expr cont
= USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us')
thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b
thenUs_ (USM expr) (USM cont)
= USM (\us -> case (expr us) of { (_, us') -> cont us' })
= USM (\us -> case (expr us) of { (# _, us' #) -> cont us' })
returnUs :: a -> UniqSM a
returnUs result = USM (\us -> (result, us))
returnUs result = USM (\us -> (# result, us #))
getUs :: UniqSM UniqSupply
getUs = USM (\us -> splitUniqSupply us)
getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #))
-- | A monad for generating unique identifiers
class Monad m => MonadUnique m where
......@@ -177,17 +180,17 @@ class Monad m => MonadUnique m where
getUniquesM = liftM uniqsFromSupply getUniqueSupplyM
instance MonadUnique UniqSM where
getUniqueSupplyM = USM (\us -> splitUniqSupply us)
getUniqueSupplyM = getUs
getUniqueM = getUniqueUs
getUniquesM = getUniquesUs
getUniqueUs :: UniqSM Unique
getUniqueUs = USM (\us -> case splitUniqSupply us of
(us1,us2) -> (uniqFromSupply us1, us2))
(us1,us2) -> (# uniqFromSupply us1, us2 #))
getUniquesUs :: UniqSM [Unique]
getUniquesUs = USM (\us -> case splitUniqSupply us of
(us1,us2) -> (uniqsFromSupply us1, us2))
(us1,us2) -> (# uniqsFromSupply us1, us2 #))
\end{code}
\begin{code}
......
......@@ -15,7 +15,7 @@ import Outputable
import Unique
import Compiler.Hoopl as Hoopl hiding (Unique)
import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique)
import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)
----------------------------------------------------------------
--- Block Ids, their environments, and their sets
......@@ -32,14 +32,14 @@ compilation unit in which it appears.
type BlockId = Hoopl.Label
instance Uniquable BlockId where
getUnique label = getUnique (uniqueToInt $ lblToUnique label)
mkBlockId :: Unique -> BlockId
mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
getUnique label = getUnique (lblToUnique label)
instance Outputable BlockId where
ppr label = ppr (getUnique label)
mkBlockId :: Unique -> BlockId
mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
retPtLbl :: BlockId -> CLabel
retPtLbl label = mkReturnPtLabel $ getUnique label
......
......@@ -32,9 +32,9 @@ module Cmm (
import CLabel
import BlockId
import CmmNode
import OptimizationFuel as F
import SMRep
import CmmExpr
import UniqSupply
import Compiler.Hoopl
import Data.Word ( Word8 )
......@@ -69,8 +69,6 @@ type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
-- (a) C--, i.e. populated with various C-- constructs
-- (Cmm and RawCmm in OldCmm.hs)
-- (b) Native code, populated with data/instructions
--
-- A second family of instances based on Hoopl is in Cmm.hs.
-- | A top-level chunk, abstracted over the type of the contents of
-- the basic blocks (Cmm or instructions are the likely instantiations).
......@@ -95,19 +93,23 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C
type CmmReplGraph e x = GenCmmReplGraph CmmNode e x
type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
type GenCmmReplGraph n e x = UniqSM (Maybe (Graph n e x))
type CmmFwdRewrite f = FwdRewrite UniqSM CmmNode f
type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
-----------------------------------------------------------------------------
-- Info Tables
-----------------------------------------------------------------------------
data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
data CmmTopInfo = TopInfo { info_tbl :: CmmInfoTable
, stack_info :: CmmStackInfo }
data CmmStackInfo
= StackInfo {
arg_space :: ByteOff, -- XXX: comment?
arg_space :: ByteOff,
-- number of bytes of arguments on the stack on entry to the
-- the proc. This is filled in by StgCmm.codeGen, and used
-- by the stack allocator later.
updfr_space :: Maybe ByteOff -- XXX: comment?
}
......
......@@ -14,168 +14,52 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmBuildInfoTables
( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT, setInfoTableStackMap
, setInfoTableSRT
, TopSRT, emptySRT, srtToData
, bundleCAFs
, lowerSafeForeignCalls
, cafTransfers, liveSlotTransfers
, mkLiveness )
, cafTransfers )
where
#include "HsVersions.h"
-- These should not be imported here!
import StgCmmForeign
import StgCmmUtils
import Constants
import Digraph
import qualified Prelude as P
import Prelude hiding (succ)
import Util
import BlockId
import Bitmap
import CLabel
import Cmm
import CmmUtils
import CmmStackLayout
import Module
import FastString
import ForeignCall
import IdInfo
import Data.List
import Maybes
import MkGraph as M
import Control.Monad
import Name
import OptimizationFuel
import Outputable
import SMRep
import UniqSupply
import Compiler.Hoopl
import Hoopl
import Data.Map (Map)
import qualified Data.Map as Map
import qualified FiniteMap as Map
import Data.Set (Set)
import qualified Data.Set as Set
foldSet :: (a -> b -> b) -> b -> Set a -> b
#if __GLASGOW_HASKELL__ < 704
foldSet = Set.fold
#else
foldSet = Set.foldr
#endif
----------------------------------------------------------------
-- Building InfoTables
-----------------------------------------------------------------------
-- Stack Maps
-- Given a block ID, we return a representation of the layout of the stack,
-- as suspended before entering that block.
-- (For a return site to a function call, the layout does not include the
-- parameter passing area (or the "return address" on the stack)).
-- If the element is `Nothing`, then it represents a word of the stack that
-- does not contain a live pointer.
-- If the element is `Just` a register, then it represents a live spill slot
-- for a pointer; we assume that a pointer is the size of a word.
-- The head of the list represents the young end of the stack where the infotable
-- pointer for the block `Bid` is stored.
-- The infotable pointer itself is not included in the list.
-- Call areas are also excluded from the list: besides the stuff in the update
-- frame (and the return infotable), call areas should never be live across
-- function calls.
-- RTS Invariant: All pointers must be word-aligned because each bit in the bitmap
-- represents a word. Consequently, we have to be careful when we see a live slot
-- on the stack: if we have packed multiple sub-word values into a word,
-- we have to make sure that we only mark the entire word as a non-pointer.
-- Also, don't forget to stop at the old end of the stack (oldByte),
-- which may differ depending on whether there is an update frame.
type RegSlotInfo
= ( Int -- Offset from oldest byte of Old area
, LocalReg -- The register
, Int) -- Width of the register
live_ptrs :: ByteOff -> BlockEnv SubAreaSet -> AreaMap -> BlockId -> StackLayout
live_ptrs oldByte slotEnv areaMap bid =
-- pprTrace "live_ptrs for" (ppr bid <+> text (show oldByte ++ "-" ++ show youngByte) <+>
-- ppr liveSlots) $
-- pprTrace ("stack layout for " ++ show bid ++ ": ") (ppr res) $ res
res
where
res = mkLiveness (reverse $ slotsToList youngByte liveSlots [])
slotsToList :: Int -> [RegSlotInfo] -> [Maybe LocalReg] -> [Maybe LocalReg]
-- n starts at youngByte and is decremented down to oldByte
-- Returns a list, one element per word, with
-- (Just r) meaning 'pointer register r is saved here',
-- Nothing meaning 'non-pointer or empty'
slotsToList n [] results | n == oldByte = results -- at old end of stack frame
slotsToList n (s : _) _ | n == oldByte =
pprPanic "slot left off live_ptrs" (ppr s <+> ppr oldByte <+>
ppr n <+> ppr liveSlots <+> ppr youngByte)
slotsToList n _ _ | n < oldByte =
panic "stack slots not allocated on word boundaries?"
slotsToList n l@((n', r, w) : rst) results =
if n == (n' + w) then -- slot's young byte is at n
ASSERT (not (isPtr r) ||
(n `mod` wORD_SIZE == 0 && w == wORD_SIZE)) -- ptrs must be aligned
slotsToList next (dropWhile (non_ptr_younger_than next) rst)
(stack_rep : results)
else slotsToList next (dropWhile (non_ptr_younger_than next) l)
(Nothing : results)
where next = n - wORD_SIZE
stack_rep = if isPtr r then Just r else Nothing
slotsToList n [] results = slotsToList (n - wORD_SIZE) [] (Nothing : results)
non_ptr_younger_than next (n', r, w) =
n' + w > next &&
ASSERT (not (isPtr r))
True
isPtr = isGcPtrType . localRegType
liveSlots :: [RegSlotInfo]
liveSlots = sortBy (\ (off,_,_) (off',_,_) -> compare off' off)
(Map.foldRightWithKey (\_ -> flip $ foldl add_slot) [] slots)
add_slot :: [RegSlotInfo] -> SubArea -> [RegSlotInfo]
add_slot rst (a@(RegSlot r@(LocalReg _ ty)), off, w) =
if off == w && widthInBytes (typeWidth ty) == w then
(expectJust "add_slot" (Map.lookup a areaMap), r, w) : rst
else panic "live_ptrs: only part of a variable live at a proc point"
add_slot rst (CallArea Old, _, _) =
rst -- the update frame (or return infotable) should be live
-- would be nice to check that only that part of the callarea is live...
add_slot rst ((CallArea _), _, _) =
rst
-- JD: THIS ISN'T CURRENTLY A CORRECTNESS PROBLEM, BUT WE SHOULD REALLY
-- MAKE LIVENESS INFO AROUND CALLS MORE PRECISE -- FOR NOW, A 32-BIT
-- FLOAT PADS OUT TO 64 BITS, BUT WE ASSUME THE WHOLE PARAMETER-PASSING
-- AREA IS LIVE (WHICH IT ISN'T...). WE SHOULD JUST PUT THE LIVE AREAS
-- IN THE CALL NODES, WHICH SHOULD EVENTUALLY HAVE LIVE REGISTER AS WELL,
-- SO IT'S ALL GOING IN THE SAME DIRECTION.
-- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
slots :: SubAreaSet -- The SubAreaSet for 'bid'
slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv
youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
-- Construct the stack maps for a procedure _if_ it needs an infotable.
-- When wouldn't a procedure need an infotable? If it is a procpoint that
-- is not the successor of a call.
setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmDecl -> CmmDecl
setInfoTableStackMap slotEnv areaMap
t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _
(CmmGraph {g_entry = eid}))
= updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
setInfoTableStackMap _ _ t = t
-----------------------------------------------------------------------
-- SRTs
......@@ -191,14 +75,14 @@ setInfoTableStackMap _ _ t = t
-----------------------------------------------------------------------
-- Finding the CAFs used by a procedure
type CAFSet = Map CLabel ()
type CAFSet = Set CLabel
type CAFEnv = BlockEnv CAFSet
-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice "live cafs" Map.empty add
where add _ (OldFact old) (NewFact new) = case old `Map.union` new of
new' -> (changeIf $ Map.size new' > Map.size old, new')
cafLattice = DataflowLattice "live cafs" Set.empty add
where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
new' -> (changeIf $ Set.size new' > Set.size old, new')
cafTransfers :: BwdTransfer CmmNode CAFSet
cafTransfers = mkBTransfer3 first middle last
......@@ -210,11 +94,11 @@ cafTransfers = mkBTransfer3 first middle last
CmmLit (CmmLabelOff c _) -> add c set
CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
_ -> set
add l s = if hasCAF l then Map.insert (toClosureLbl l) () s
add l s = if hasCAF l then Set.insert (toClosureLbl l) s
else s
cafAnal :: CmmGraph -> FuelUniqSM CAFEnv
cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers
cafAnal :: CmmGraph -> CAFEnv
cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
-----------------------------------------------------------------------
-- Building the SRTs
......@@ -264,15 +148,15 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
FuelUniqSM (TopSRT, Maybe CmmDecl, C_SRT)
UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl () z = -- get CAFs for functions without static closures
case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs
Nothing -> Map.insert lbl () z
do let liftCAF lbl z = -- get CAFs for functions without static closures
case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
Nothing -> Set.insert lbl z
-- For each label referring to a function f without a static closure,
-- replace it with the CAFs that are reachable from f.
sub_srt topSRT localCafs =
let cafs = Map.keys (Map.foldRightWithKey liftCAF Map.empty localCafs)
let cafs = Set.elems (foldSet liftCAF Set.empty localCafs)
mkSRT topSRT =
do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
return (topSRT, localSRTs)
......@@ -307,7 +191,7 @@ buildSRTs topSRT topCAFMap cafs =
-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
FuelUniqSM (Maybe CmmDecl, C_SRT)
UniqSM (Maybe CmmDecl, C_SRT)
procpointSRT _ _ [] =
return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
......@@ -315,7 +199,7 @@ procpointSRT top_srt top_table entries =
return (top, srt)
where
ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
sorted_ints = sortLe (<=) ints
sorted_ints = sort ints
offset = head sorted_ints
bitmap_entries = map (subtract offset) sorted_ints
len = P.last bitmap_entries + 1
......@@ -325,7 +209,7 @@ maxBmpSize :: Int
maxBmpSize = widthInBits wordWidth `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmDecl, C_SRT)
to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT top_srt off len bmp
| len > maxBmpSize || bmp == [fromIntegral srt_escape]
= do id <- getUniqueM
......@@ -373,30 +257,30 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
Map.insert l (flatten env cafset) env
addToTop env (CyclicSCC nodes) =
let (lbls, cafsets) = unzip nodes
cafset = lbls `Map.deleteList` foldl Map.union Map.empty cafsets
cafset = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls