+instance DefinerOfLocalRegs Middle where
+ foldRegsDefd f z m = middle m
+ where middle (MidComment {}) = z
+ middle (MidAssign lhs _) = fold f z lhs
+ middle (MidStore _ _) = z
+ middle (MidForeignCall _ _ fs _) = fold f z fs
+ fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
+
+instance DefinerOfLocalRegs Last where
+ foldRegsDefd _ z _ = z
+
+
+----------------------------------------------------------------------
+----- Instance declarations for stack slot use
+
+instance UserOfSlots Middle where
+ foldSlotsUsed f z m = middle m
+ where middle (MidComment {}) = z
+ middle (MidAssign _lhs expr) = fold f z expr
+ middle (MidStore addr rval) = fold f (fold f z addr) rval
+ middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
+ fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
+
+instance UserOfSlots Last where
+ foldSlotsUsed f z l = last l
+ where last (LastBranch _id) = z
+ last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
+ last (LastCondBranch e _ _) = foldSlotsUsed f z e
+ last (LastSwitch e _tbl) = foldSlotsUsed f z e
+
+instance UserOfSlots l => UserOfSlots (ZLast l) where
+ foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
+ foldSlotsUsed _ z LastExit = z
+
+instance DefinerOfSlots Middle where
+ foldSlotsDefd f z m = middle m
+ where middle (MidComment {}) = z
+ middle (MidAssign _ _) = z
+ middle (MidForeignCall {}) = z
+ middle (MidStore (CmmStackSlot a i) e) =
+ f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
+ middle (MidStore _ _) = z
+
+instance DefinerOfSlots Last where
+ foldSlotsDefd _ z _ = z
+
+instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
+ foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
+ foldSlotsDefd _ z LastExit = z
+
+----------------------------------------------------------------------
+----- Code for manipulating Middle and Last nodes
+
+mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
+mapExpMiddle _ m@(MidComment _) = m
+mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
+mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
+mapExpMiddle exp (MidForeignCall s tgt fs as) =
+ MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
+
+foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
+foldExpMiddle _ (MidComment _) z = z
+foldExpMiddle exp (MidAssign _ e) z = exp e z
+foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
+foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
+
+mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
+mapExpLast _ l@(LastBranch _) = l
+mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
+mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
+mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
+
+foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
+foldExpLast _ (LastBranch _) z = z
+foldExpLast exp (LastCondBranch e _ _) z = exp e z
+foldExpLast exp (LastSwitch e _) z = exp e z
+foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
+
+mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
+mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
+mapExpMidcall _ m@(PrimTarget _) = m
+
+foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
+foldExpMidcall exp (ForeignTarget e _) z = exp e z
+foldExpMidcall _ (PrimTarget _) z = z
+
+-- 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
+
+mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
+mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
+mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
+mapExpDeepLast f = mapExpLast $ wrapRecExp f
+
+-- 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
+
+foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
+foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
+foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
+foldExpDeepLast f = foldExpLast $ wrapRecExpf f
+
+----------------------------------------------------------------------
+-- Compute the join of facts live out of a Last node. Useful for most backward
+-- analyses.
+joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
+joinOuts lattice env l =
+ let bot = fact_bot lattice
+ join x y = txVal $ fact_add_to lattice x y
+ in case l of
+ (LastBranch id) -> env id
+ (LastCall _ Nothing _ _ _) -> bot
+ (LastCall _ (Just k) _ _ _) -> env k
+ (LastCondBranch _ t f) -> join (env t) (env f)
+ (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)