X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmm.hs;h=4ea7f00b6aec113e6ab24c4b3d94c31dd41e46ab;hp=afa47a24f709cca653993794d518c61fbec15e2c;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=3f070beb602a1b40d185ec49f7b556a7cc624d51 diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index afa47a2..4ea7f00 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -7,43 +7,39 @@ ----------------------------------------------------------------------------- module Cmm ( - GenCmm(..), Cmm, RawCmm, - GenCmmTop(..), CmmTop, RawCmmTop, - ListGraph(..), + GenCmm(..), Cmm, RawCmm, + GenCmmTop(..), CmmTop, RawCmmTop, + ListGraph(..), cmmMapGraph, cmmTopMapGraph, cmmMapGraphM, cmmTopMapGraphM, - CmmInfo(..), UpdateFrame(..), - CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, + CmmInfo(..), UpdateFrame(..), + CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, + ProfilingInfo(..), ClosureTypeTag, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, CmmReturnInfo(..), - CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, CmmKind, - CmmFormalsWithoutKinds, CmmFormalWithoutKind, + CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, + HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals, CmmSafety(..), - CmmCallTarget(..), - CmmStatic(..), Section(..), + CmmCallTarget(..), CallishMachOp(..), pprCallishMachOp, + ForeignHint(..), CmmHinted(..), + CmmStatic(..), Section(..), module CmmExpr, - BlockId(..), freshBlockId, - BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv, - BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, ) where #include "HsVersions.h" +import BlockId import CmmExpr -import MachOp import CLabel import ForeignCall import SMRep + import ClosureInfo import Outputable import FastString import Data.Word -import ZipCfg ( BlockId(..), freshBlockId - , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv - , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet - ) -- A [[BlockId]] is a local label. -- Local labels must be unique within an entire compilation unit, not @@ -51,7 +47,7 @@ import ZipCfg ( BlockId(..), freshBlockId -- with assembly-language labels. ----------------------------------------------------------------------------- --- Cmm, CmmTop, CmmBasicBlock +-- Cmm, CmmTop, CmmBasicBlock ----------------------------------------------------------------------------- -- A file is a list of top-level chunks. These may be arbitrarily @@ -64,7 +60,7 @@ import ZipCfg ( BlockId(..), freshBlockId -- -- We expect there to be two main instances of this type: -- (a) C--, i.e. populated with various C-- constructs --- (Cmm and RawCmm below) +-- (Cmm and RawCmm below) -- (b) Native code, populated with data/instructions -- -- A second family of instances based on ZipCfg is work in progress. @@ -77,7 +73,7 @@ data GenCmmTop d h g = CmmProc -- A procedure h -- Extra header such as the info table CLabel -- Used to generate both info & entry labels - CmmFormalsWithoutKinds -- Argument locals live on entry (C-- procedure params) + CmmFormals -- Argument locals live on entry (C-- procedure params) -- XXX Odd that there are no kinds, but there you are ---NR g -- Control-flow graph for the procedure's code @@ -139,10 +135,11 @@ cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (Gen cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds +cmmTopMapGraph _ (CmmData s ds) = CmmData s ds cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm -cmmTopMapGraphM f (CmmProc h l args g) = f (showSDoc $ ppr l) g >>= return . CmmProc h l args +cmmTopMapGraphM f (CmmProc h l args g) = + f (showSDoc $ ppr l) g >>= return . CmmProc h l args cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds ----------------------------------------------------------------------------- @@ -152,32 +149,39 @@ cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds data CmmInfo = CmmInfo (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check + -- JD: NOT USED BY NEW CODE GEN (Maybe UpdateFrame) -- Update frame CmmInfoTable -- Info table -- Info table as a haskell data type data CmmInfoTable = CmmInfoTable + HasStaticClosure ProfilingInfo ClosureTypeTag -- Int ClosureTypeInfo | CmmNonInfoTable -- Procedure doesn't need an info table +type HasStaticClosure = Bool + -- TODO: The GC target shouldn't really be part of CmmInfo -- as it doesn't appear in the resulting info table. -- It should be factored out. data ClosureTypeInfo = ConstrInfo ClosureLayout ConstrTag ConstrDescription - | FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry - | ThunkInfo ClosureLayout C_SRT + | FunInfo ClosureLayout C_SRT FunArity ArgDescr SlowEntry + | ThunkInfo ClosureLayout C_SRT | ThunkSelectorInfo SelectorOffset C_SRT | ContInfo - [Maybe LocalReg] -- Forced stack parameters + [Maybe LocalReg] -- Stack layout: Just x, an item x + -- Nothing: a 1-word gap + -- Start of list is the *young* end C_SRT data CmmReturnInfo = CmmMayReturn | CmmNeverReturns + deriving ( Eq ) -- TODO: These types may need refinement data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc @@ -185,10 +189,9 @@ type ClosureTypeTag = StgHalfWord type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs type ConstrTag = StgHalfWord type ConstrDescription = CmmLit -type FunType = StgHalfWord type FunArity = StgHalfWord type SlowEntry = CmmLit - -- ^We would like this to be a CLabel but + -- We would like this to be a CLabel but -- for now the parser sets this to zero on an INFO_TABLE_FUN. type SelectorOffset = StgWord @@ -206,19 +209,19 @@ data UpdateFrame = -- control to a new function. ----------------------------------------------------------------------------- -data CmmStmt +data CmmStmt -- Old-style = CmmNop | CmmComment FastString | CmmAssign CmmReg CmmExpr -- Assign to register | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprRep of the rhs. + -- given by cmmExprType of the rhs. | CmmCall -- A call (forign, native or primitive), with CmmCallTarget - CmmFormals -- zero or more results - CmmActuals -- zero or more arguments + HintedCmmFormals -- zero or more results + HintedCmmActuals -- zero or more arguments CmmSafety -- whether to build a continuation CmmReturnInfo @@ -233,43 +236,62 @@ data CmmStmt -- Undefined outside range, and when there's a Nothing | CmmJump CmmExpr -- Jump to another C-- function, - CmmActuals -- with these parameters. + HintedCmmActuals -- with these parameters. (parameters never used) | CmmReturn -- Return from a native C-- function, - CmmActuals -- with these return values. + HintedCmmActuals -- with these return values. (parameters never used) -type CmmKind = MachHint -type CmmActual = (CmmExpr, CmmKind) -type CmmFormal = (LocalReg,CmmKind) +type CmmActual = CmmExpr +type CmmFormal = LocalReg type CmmActuals = [CmmActual] type CmmFormals = [CmmFormal] -type CmmFormalWithoutKind = LocalReg -type CmmFormalsWithoutKinds = [CmmFormalWithoutKind] -data CmmSafety = CmmUnsafe | CmmSafe C_SRT +data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint } + deriving( Eq ) --- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals' -instance UserOfLocalRegs a => UserOfLocalRegs (a, CmmKind) where - foldRegsUsed f set (a, _) = foldRegsUsed f set a +type HintedCmmActuals = [HintedCmmActual] +type HintedCmmFormals = [HintedCmmFormal] +type HintedCmmFormal = CmmHinted CmmFormal +type HintedCmmActual = CmmHinted CmmActual +data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible + +-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals' instance UserOfLocalRegs CmmStmt where - foldRegsUsed f set s = stmt s set - where stmt (CmmNop) = id - stmt (CmmComment {}) = id - stmt (CmmAssign _ e) = gen e - stmt (CmmStore e1 e2) = gen e1 . gen e2 - stmt (CmmCall target _ es _ _) = gen target . gen es - stmt (CmmBranch _) = id - stmt (CmmCondBranch e _) = gen e - stmt (CmmSwitch e _) = gen e - stmt (CmmJump e es) = gen e . gen es - stmt (CmmReturn es) = gen es - gen a set = foldRegsUsed f set a + foldRegsUsed f (set::b) s = stmt s set + where + stmt :: CmmStmt -> b -> b + stmt (CmmNop) = id + stmt (CmmComment {}) = id + stmt (CmmAssign _ e) = gen e + stmt (CmmStore e1 e2) = gen e1 . gen e2 + stmt (CmmCall target _ es _ _) = gen target . gen es + stmt (CmmBranch _) = id + stmt (CmmCondBranch e _) = gen e + stmt (CmmSwitch e _) = gen e + stmt (CmmJump e es) = gen e . gen es + stmt (CmmReturn es) = gen es + + gen :: UserOfLocalRegs a => a -> b -> b + gen a set = foldRegsUsed f set a instance UserOfLocalRegs CmmCallTarget where foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e foldRegsUsed _ set (CmmPrim {}) = set +instance UserOfSlots CmmCallTarget where + foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e + foldSlotsUsed _ set (CmmPrim {}) = set + +instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where + foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) + +instance UserOfSlots a => UserOfSlots (CmmHinted a) where + foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a) + +instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where + foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a) + {- Discussion ~~~~~~~~~~ @@ -325,7 +347,54 @@ data CmmCallTarget | CmmPrim -- Call a "primitive" (eg. sin, cos) CallishMachOp -- These might be implemented as inline -- code by the backend. - + deriving Eq + + +data ForeignHint + = NoHint | AddrHint | SignedHint + deriving( Eq ) + -- Used to give extra per-argument or per-result + -- information needed by foreign calling conventions + + +-- CallishMachOps tend to be implemented by foreign calls in some backends, +-- so we separate them out. In Cmm, these can only occur in a +-- statement position, in contrast to an ordinary MachOp which can occur +-- anywhere in an expression. +data CallishMachOp + = MO_F64_Pwr + | MO_F64_Sin + | MO_F64_Cos + | MO_F64_Tan + | MO_F64_Sinh + | MO_F64_Cosh + | MO_F64_Tanh + | MO_F64_Asin + | MO_F64_Acos + | MO_F64_Atan + | MO_F64_Log + | MO_F64_Exp + | MO_F64_Sqrt + | MO_F32_Pwr + | MO_F32_Sin + | MO_F32_Cos + | MO_F32_Tan + | MO_F32_Sinh + | MO_F32_Cosh + | MO_F32_Tanh + | MO_F32_Asin + | MO_F32_Acos + | MO_F32_Atan + | MO_F32_Log + | MO_F32_Exp + | MO_F32_Sqrt + | MO_WriteBarrier + | MO_Touch -- Keep variables live (when using interior pointers) + deriving (Eq, Show) + +pprCallishMachOp :: CallishMachOp -> SDoc +pprCallishMachOp mo = text (show mo) + ----------------------------------------------------------------------------- -- Static Data -----------------------------------------------------------------------------