+mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals
+
+cmmResConv :: Convention
+cmmResConv = Native
+
+-- Return the number of bytes used for copying arguments, as well as the
+-- instructions to copy the arguments.
+copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, [Middle])
+copyIn _ isCall area formals =
+ foldr ci (init_offset, []) $ assignArgumentsPos isCall localRegType formals
+ where ci (reg, RegisterParam r) (n, ms) =
+ (n, MidAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
+ ci (reg, StackParam off) (n, ms) =
+ let ty = localRegType reg
+ off' = off + init_offset
+ in (max n off',
+ MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) : ms)
+ init_offset = widthInBytes wordWidth
+
+-- 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.
+copyOut :: Convention -> Transfer -> Area -> CmmActuals -> (Int, [Middle])
+copyOut _ transfer area@(CallArea a) actuals =
+ foldr co (init_offset, []) args'
+ where args = assignArgumentsPos skip_node cmmExprType actuals
+ skip_node = transfer /= Ret
+ (setRA, init_offset) =
+ case a of Young id -> -- set RA if making a call
+ if transfer == Call then
+ ([(CmmLit (CmmLabel (infoTblLbl id)),
+ StackParam init_offset)], ra_width)
+ else ([], 0)
+ Old -> ([], ra_width)
+ ra_width = widthInBytes wordWidth
+ args' = foldl adjust setRA args
+ where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+ adjust rst x@(_, RegisterParam _) = x : rst
+ 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)
+copyOut _ _ (RegSlot _) _ = panic "cannot copy arguments into a register slot"
+
+mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
+mkEntry _ conv formals =
+ let (off, copies) = copyIn conv False (CallArea Old) formals in
+ (off, mkMiddles copies)
+
+-- 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 :: Transfer -> Area -> Convention -> CmmActuals -> (Int -> Last) -> CmmAGraph
+lastWithArgs transfer area conv actuals last =
+ let (outArgs, copies) = copyOut conv transfer area actuals in
+ mkMiddles copies <*> mkLast (last outArgs)
+
+-- The area created for the jump and return arguments is the same area as the
+-- procedure entry.
+mkJump e actuals = lastWithArgs Jump (CallArea Old) cmmResConv actuals $ LastJump e
+mkReturn actuals = lastWithArgs Ret (CallArea Old) cmmResConv actuals $ LastJump e
+ where e = CmmStackSlot (CallArea Old) (widthInBytes wordWidth)
+
+mkFinalCall f _ actuals =
+ lastWithArgs Call (CallArea Old) Native actuals $ LastCall f Nothing
+
+mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
+
+-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
+mkCall f _ results actuals _ =
+ withFreshLabel "call successor" $ \k ->
+ let area = CallArea $ Young k
+ (off, copyin) = copyIn Native False area results
+ copyout = lastWithArgs Call area Native actuals $ LastCall f (Just k)
+ in copyout <*> mkLabel k (Just off) <*> (mkMiddles copyin)