--- /dev/null
+-- CmmNode type for representation using Hoopl graphs.
+{-# LANGUAGE GADTs #-}
+module CmmNode
+ ( CmmNode(..)
+ , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
+ , mapExp, mapExpDeep, foldExp, foldExpDeep
+ )
+where
+
+import CmmExpr
+import CmmDecl
+import FastString
+import ForeignCall
+import SMRep
+
+import Compiler.Hoopl
+import Data.Maybe
+import Prelude hiding (succ)
+
+
+------------------------
+-- CmmNode
+
+data CmmNode e x where
+ CmmEntry :: Label -> CmmNode C O
+ CmmComment :: FastString -> CmmNode O O
+ CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register
+ CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is
+ -- given by cmmExprType of the rhs.
+ CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls]
+ ForeignTarget -> -- call target
+ CmmFormals -> -- zero or more results
+ CmmActuals -> -- zero or more arguments
+ CmmNode O O
+ CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
+ CmmCondBranch :: { -- conditional branch
+ cml_pred :: CmmExpr,
+ cml_true, cml_false :: Label
+ } -> CmmNode O C
+ CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
+ -- The scrutinee is zero-based;
+ -- zero -> first block
+ -- one -> second block etc
+ -- Undefined outside range, and when there's a Nothing
+ CmmCall :: { -- A call (native or safe foreign)
+ cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
+
+ cml_cont :: Maybe Label,
+ -- Label of continuation (Nothing for return or tail call)
+
+ cml_args :: ByteOff,
+ -- Byte offset, from the *old* end of the Area associated with
+ -- the Label (if cml_cont = Nothing, then Old area), of
+ -- youngest outgoing arg. Set the stack pointer to this before
+ -- transferring control.
+ -- (NB: an update frame might also have been stored in the Old
+ -- area, but it'll be in an older part than the args.)
+
+ cml_ret_args :: ByteOff,
+ -- For calls *only*, the byte offset for youngest returned value
+ -- This is really needed at the *return* point rather than here
+ -- at the call, but in practice it's convenient to record it here.
+
+ cml_ret_off :: ByteOff
+ -- For calls *only*, the byte offset of the base of the frame that
+ -- must be described by the info table for the return point.
+ -- The older words are an update frames, which have their own
+ -- info-table and layout information
+
+ -- From a liveness point of view, the stack words older than
+ -- cml_ret_off are treated as live, even if the sequel of
+ -- the call goes into a loop.
+ } -> CmmNode O C
+ CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
+ tgt :: ForeignTarget, -- call target and convention
+ res :: CmmFormals, -- zero or more results
+ args :: CmmActuals, -- zero or more arguments
+ succ :: Label, -- Label of continuation
+ updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
+ intrbl:: Bool -- whether or not the call is interruptible
+ } -> CmmNode O C
+
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A MidForeign call is used for *unsafe* foreign calls;
+a LastForeign call is used for *safe* foreign calls.
+Unsafe ones are easy: think of them as a "fat machine instruction".
+
+Safe ones are trickier. A safe foreign call
+ r = f(x)
+ultimately expands to
+ push "return address" -- Never used to return to;
+ -- just points an info table
+ save registers into TSO
+ call suspendThread
+ r = f(x) -- Make the call
+ call resumeThread
+ restore registers
+ pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+Furthermore, currently the smart Cmm constructors know the calling
+conventions for Haskell, the garbage collector, etc, and "lower" them
+so that a LastCall passes no parameters or results. But the smart
+constructors do *not* (currently) know the foreign call conventions.
+
+Note that a safe foreign call needs an info table.
+-}
+
+---------------------------------------------
+-- Eq instance of CmmNode
+-- It is a shame GHC cannot infer it by itself :(
+
+instance Eq (CmmNode e x) where
+ (CmmEntry a) == (CmmEntry a') = a==a'
+ (CmmComment a) == (CmmComment a') = a==a'
+ (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b'
+ (CmmStore a b) == (CmmStore a' b') = a==a' && b==b'
+ (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
+ (CmmBranch a) == (CmmBranch a') = a==a'
+ (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
+ (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
+ (CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e'
+ (CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f'
+ _ == _ = False
+
+----------------------------------------------
+-- Hoopl instances of CmmNode
+
+instance NonLocal CmmNode where
+ entryLabel (CmmEntry l) = l
+ -- entryLabel _ = error "CmmNode.entryLabel"
+
+ successors (CmmBranch l) = [l]
+ successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
+ successors (CmmSwitch _ ls) = catMaybes ls
+ successors (CmmCall {cml_cont=l}) = maybeToList l
+ successors (CmmForeignCall {succ=l}) = [l]
+ -- successors _ = error "CmmNode.successors"
+
+
+instance HooplNode CmmNode where
+ mkBranchNode label = CmmBranch label
+ mkLabelNode label = CmmEntry label
+
+--------------------------------------------------
+-- Various helper types
+
+type UpdFrameOffset = ByteOff
+
+data Convention
+ = NativeDirectCall -- Native C-- call skipping the node (closure) argument
+ | NativeNodeCall -- Native C-- call including the node argument
+ | NativeReturn -- Native C-- return
+ | Slow -- Slow entry points: all args pushed on the stack
+ | GC -- Entry to the garbage collector: uses the node reg!
+ | PrimOpCall -- Calling prim ops
+ | PrimOpReturn -- Returning from prim ops
+ | Foreign -- Foreign call/return
+ ForeignConvention
+ | Private
+ -- Used for control transfers within a (pre-CPS) procedure All
+ -- jump sites known, never pushed on the stack (hence no SRT)
+ -- You can choose whatever calling convention you please
+ -- (provided you make sure all the call sites agree)!
+ -- This data type eventually to be extended to record the convention.
+ deriving( Eq )
+
+data ForeignConvention
+ = ForeignConvention
+ CCallConv -- Which foreign-call convention
+ [ForeignHint] -- Extra info about the args
+ [ForeignHint] -- Extra info about the result
+ deriving Eq
+
+data ForeignTarget -- The target of a foreign call
+ = ForeignTarget -- A foreign procedure
+ CmmExpr -- Its address
+ ForeignConvention -- Its calling convention
+ | PrimTarget -- A possibly-side-effecting machine operation
+ CallishMachOp -- Which one
+ deriving Eq
+
+--------------------------------------------------
+-- Instances of register and slot users / definers
+
+instance UserOfLocalRegs (CmmNode e x) where
+ foldRegsUsed f z n = case n of
+ CmmAssign _ expr -> fold f z expr
+ CmmStore addr rval -> fold f (fold f z addr) rval
+ CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+ CmmCondBranch expr _ _ -> fold f z expr
+ CmmSwitch expr _ -> fold f z expr
+ CmmCall {cml_target=tgt} -> fold f z tgt
+ CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+ _ -> z
+ where fold :: forall a b.
+ UserOfLocalRegs a =>
+ (b -> LocalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsUsed f z n
+
+instance UserOfLocalRegs ForeignTarget where
+ foldRegsUsed _f z (PrimTarget _) = z
+ foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs (CmmNode e x) where
+ foldRegsDefd f z n = case n of
+ CmmAssign lhs _ -> fold f z lhs
+ CmmUnsafeForeignCall _ fs _ -> fold f z fs
+ CmmForeignCall {res=res} -> fold f z res
+ _ -> z
+ where fold :: forall a b.
+ DefinerOfLocalRegs a =>
+ (b -> LocalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsDefd f z n
+
+
+instance UserOfSlots (CmmNode e x) where
+ foldSlotsUsed f z n = case n of
+ CmmAssign _ expr -> fold f z expr
+ CmmStore addr rval -> fold f (fold f z addr) rval
+ CmmUnsafeForeignCall _ _ args -> fold f z args
+ CmmCondBranch expr _ _ -> fold f z expr
+ CmmSwitch expr _ -> fold f z expr
+ CmmCall {cml_target=tgt} -> fold f z tgt
+ CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+ _ -> z
+ where fold :: forall a b.
+ UserOfSlots a =>
+ (b -> SubArea -> b) -> b -> a -> b
+ fold f z n = foldSlotsUsed f z n
+
+instance UserOfSlots ForeignTarget where
+ foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
+ foldSlotsUsed _f z (PrimTarget _) = z
+
+instance DefinerOfSlots (CmmNode e x) where
+ foldSlotsDefd f z n = case n of
+ CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
+ CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
+ _ -> z
+ where
+ fold :: forall a b.
+ DefinerOfSlots a =>
+ (b -> SubArea -> b) -> b -> a -> b
+ fold f z n = foldSlotsDefd f z n
+ foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
+
+-----------------------------------
+-- mapping Expr in CmmNode
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _ m@(PrimTarget _) = m
+
+-- Take a transformer on expressions and apply it recursively.
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry _) = f
+mapExp _ m@(CmmComment _) = m
+mapExp f (CmmAssign r e) = CmmAssign r (f e)
+mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
+mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _) = l
+mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
+mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
+mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s
+mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+-----------------------------------
+-- folding Expr in CmmNode
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _ (PrimTarget _) z = z
+
+-- Take a folder on expressions and apply it recursively.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z = z
+foldExp _ (CmmComment {}) z = z
+foldExp f (CmmAssign _ e) z = f e z
+foldExp f (CmmStore addr e) z = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z = z
+foldExp f (CmmCondBranch e _ _) z = f e z
+foldExp f (CmmSwitch e _) z = f e z
+foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp $ wrapRecExpf f
projects / ghc-hetmet.git / blobdiff