diff options
Diffstat (limited to 'compiler/cmm/CmmNode.hs')
| -rw-r--r-- | compiler/cmm/CmmNode.hs | 303 |
1 files changed, 303 insertions, 0 deletions
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs new file mode 100644 index 0000000000..12d534ea53 --- /dev/null +++ b/compiler/cmm/CmmNode.hs @@ -0,0 +1,303 @@ +-- 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 |