-mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot
-mkSwitch e tbl = mkLast $ LastSwitch e tbl
-
-mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
-mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals
-
-cmmResConv :: Convention
-cmmResConv = ConventionStandard CmmCallConv Results
-
-copyIn :: Convention -> Area -> CmmFormals -> [Middle]
-copyIn _ area formals = reverse $ snd $ foldl ci (1, []) formals
- where ci (n, ms) v = (n+1, MidAssign (CmmLocal $ kindlessCmm v)
- (CmmLoad (CmmStackSlot area n) wordRep) : ms)
-
-copyOut :: Convention -> Area -> CmmActuals -> [Middle]
-copyOut conv area actuals = moveSP conv $ snd $ foldl co (1, []) actuals
- where moveSP (ConventionStandard _ Arguments) args =
- MidAssign spReg (outgoingSlot area) : reverse args
- moveSP _ args = reverse $ MidAssign spReg (outgoingSlot area) : args
- co (n, ms) v = (n+1, MidStore (CmmStackSlot area n) (kindlessCmm v) : ms)
-mkEntry :: Area -> Convention -> CmmFormalsWithoutKinds -> [Middle]
-mkEntry area conv formals = copyIn conv area fs
- where fs = map (\f -> CmmKinded f NoHint) formals
-
--- I'm not sure how to get the calling conventions right yet,
--- and I suspect this should not be resolved until sometime after
--- Simon's patch is applied.
--- For now, I apply a bogus calling convention: all arguments go on the
--- stack, using the same amount of stack space.
-lastWithArgs' :: BlockId -> Area -> Convention -> CmmActuals -> Maybe CmmFormals ->
- (BlockId -> Last) -> CmmAGraph
-lastWithArgs' k area conv actuals formals toLast =
- (mkMiddles $ copyOut conv area actuals) <*>
- -- adjust the sp
- mkLast (toLast k) <*>
- case formals of
- Just formals -> mkLabel k <*> (mkMiddles $ copyIn conv area formals)
- Nothing -> emptyAGraph
-lastWithArgs :: Convention -> CmmActuals -> Maybe CmmFormals -> (BlockId -> Last) -> CmmAGraph
-lastWithArgs c a f l =
- withFreshLabel "call successor" $ \k -> lastWithArgs' k (mkCallArea k a f) c a f l
-
-always :: a -> b -> a
-always x _ = x
+-- NEED A COMPILER-DEBUGGING FLAG HERE
+-- Sanity check: any value assigned to a pointer must be non-zero.
+-- If it's 0, cause a crash immediately.
+mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
+ where assign l r = mkMiddle (MidAssign l r)
+ check (CmmGlobal _) = mkNop
+ check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
+ if isGcPtrType ty then
+ mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
+ (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
+ else mkNop
+ where ty = localRegType reg
+ w = typeWidth ty
+ r = CmmReg l
+
+
+-- Why are we inserting extra blocks that simply branch to the successors?
+-- Because in addition to the branch instruction, @mkBranch@ will insert
+-- a necessary adjustment to the stack pointer.
+mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
+mkSwitch e tbl = mkLast $ LastSwitch e tbl
+
+mkSafeCall t fs as upd =
+ withFreshLabel "safe call" $ \k ->
+ mkMiddle $ MidForeignCall (Safe k upd) t fs as
+mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
+
+-- For debugging purposes, we can stub out dead stack slots:
+stackStubExpr :: Width -> CmmExpr
+stackStubExpr w = CmmLit (CmmInt 0 w)
+
+-- When we copy in parameters, we usually want to put overflow
+-- parameters on the stack, but sometimes we want to pass
+-- the variables in their spill slots.
+-- Therefore, for copying arguments and results, we provide different
+-- functions to pass the arguments in an overflow area and to pass them in spill slots.
+copyInOflow :: Convention -> Bool -> Area -> CmmFormals -> (Int, CmmAGraph)
+copyInSlot :: Convention -> Bool -> CmmFormals -> CmmAGraph
+copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
+ (Int, [Middle])
+copyOutSlot :: Convention -> Transfer -> [LocalReg] -> [Middle]
+ -- why a list of middles here instead of an AGraph?
+
+copyInOflow = copyIn oneCopyOflowI
+copyInSlot c i f = snd $ copyIn oneCopySlotI c i (panic "no area for copying to slots") f
+
+type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
+ (ByteOff, CmmAGraph)
+type CopyIn = SlotCopier -> Convention -> Bool -> Area -> CmmFormals ->
+ (ByteOff, CmmAGraph)
+
+-- Return the number of bytes used for copying arguments, as well as the
+-- instructions to copy the arguments.
+copyIn :: CopyIn
+copyIn oflow conv isCall area formals =
+ foldr ci (init_offset, mkNop) args'
+ where ci (reg, RegisterParam r) (n, ms) =
+ (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
+ ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
+ init_offset = widthInBytes wordWidth -- infotable
+ args = assignArgumentsPos conv isCall localRegType formals
+ args' = foldl adjust [] args
+ where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+ adjust rst x@(_, RegisterParam _) = x : rst
+
+-- Copy-in one arg, using overflow space if needed.
+oneCopyOflowI, oneCopySlotI :: SlotCopier
+oneCopyOflowI area (reg, off) (n, ms) =
+ (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
+ where ty = localRegType reg
+
+-- Copy-in one arg, using spill slots if needed -- used for calling conventions at
+-- a procpoint that is not a return point. The offset is irrelevant here...
+oneCopySlotI _ (reg, _) (n, ms) =
+ (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
+ where ty = localRegType reg
+ w = widthInBytes (typeWidth ty)
+
+
+-- Factoring out the common parts of the copyout functions yielded something
+-- more complicated:
+
+-- The argument layout function ignores the pointer to the info table, so we slot that
+-- in here. When copying-out to a young area, we set the info table for return
+-- and adjust the offsets of the other parameters.
+-- If this is a call instruction, we adjust the offsets of the other parameters.
+copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
+ foldr co (init_offset, []) args'
+ where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
+ co (v, StackParam off) (n, ms) =
+ (max n off, MidStore (CmmStackSlot area off) v : ms)
+ (setRA, init_offset) =
+ case a of Young id@(BlockId _) -> -- set RA if making a call
+ if transfer == Call then
+ ([(CmmLit (CmmBlock id), StackParam init_offset)],
+ widthInBytes wordWidth)
+ else ([], 0)
+ Old -> ([], updfr_off)
+ args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals
+ args' = foldl adjust setRA args
+ where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+ adjust rst x@(_, RegisterParam _) = x : rst
+copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
+
+-- Args passed only in registers and stack slots; no overflow space.
+-- No return address may apply!
+copyOutSlot conv transfer actuals = foldr co [] args
+ where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
+ co (v, StackParam off) ms =
+ MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
+ toExp r = CmmReg (CmmLocal r)
+ args = assignArgumentsPos conv (transfer /= Ret) localRegType actuals
+
+-- oneCopySlotO _ (reg, _) (n, ms) =
+-- (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
+-- where w = widthInBytes (typeWidth (localRegType reg))
+
+mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
+mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals
+
+lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
+ (ByteOff -> Last) -> CmmAGraph
+lastWithArgs transfer area conv actuals updfr_off last =
+ let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
+ mkMiddles copies <*> mkLast (last outArgs)