MkZipCfgCmm.hs 12 KB
Newer Older
1
2
3
4
5
6
7
8
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}

-- This is the module to import to be able to build C-- programs.
-- It should not be necessary to import MkZipCfg or ZipCfgCmmRep.
-- If you find it necessary to import these other modules, please
-- complain to Norman Ramsey.

module MkZipCfgCmm
9
10
  ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
         , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
11
         , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
12
         , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
13
  , (<*>), catAGraphs, mkLabel, mkBranch
14
15
  , emptyAGraph, withFreshLabel, withUnique, outOfLine
  , lgraphOfAGraph, graphOfAGraph, labelAGraph
16
  , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
17
  , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
18
  , stackStubExpr, pprAGraph
19
20
21
22
23
  )
where

#include "HsVersions.h"

24
import BlockId
25
26
import CmmExpr
import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
27
           , CmmActuals, CmmFormals
28
           )
29
import CmmCallConv (assignArgumentsPos, ParamLocation(..))
30
import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
Thomas Schilling's avatar
Thomas Schilling committed
31
32
  -- to make this module more self-contained, the above definitions are
  -- duplicated below
33
34
35
36
37
import PprCmm()

import FastString
import ForeignCall
import MkZipCfg
38
import Outputable
39
import Panic 
40
import SMRep (ByteOff) 
41
import StaticFlags 
42
import ZipCfg 
43
44
45
46

type CmmGraph  = LGraph Middle Last
type CmmAGraph = AGraph Middle Last
type CmmBlock  = Block  Middle Last
47
48
49
50
type CmmStackInfo            = (ByteOff, Maybe ByteOff)
  -- probably want a record; (SP offset on entry, update frame space)
type CmmZ                    = GenCmm    CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
51

52
53
data Transfer = Call | Jump | Ret deriving Eq

54
---------- No-ops
55
mkNop        :: CmmAGraph
56
57
58
mkComment    :: FastString -> CmmAGraph

---------- Assignment and store
59
60
mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
61
62

---------- Calls
63
mkCall       :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
64
65
66
                  UpdFrameOffset -> CmmAGraph
mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
                  UpdFrameOffset -> CmmAGraph
67
			-- Native C-- calling convention
68
69
70
mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
71
		 -- Never returns; like exit() or barf()
72

73
---------- Control transfer
74
75
76
mkJump       	::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkJumpGC       	::               CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkForeignJump   :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
77
78
mkCbranch    	:: CmmExpr -> BlockId -> BlockId          -> CmmAGraph
mkSwitch     	:: CmmExpr -> [Maybe BlockId]             -> CmmAGraph
79
80
mkReturn     	:: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
mkReturnSimple  :: CmmActuals -> UpdFrameOffset -> CmmAGraph
81

82
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
83
mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
84
mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
85

86
87
-- Not to be forgotten, but exported by MkZipCfg:
-- mkBranch   	  :: BlockId -> CmmAGraph
88
-- mkLabel    	  :: BlockId -> Maybe Int -> CmmAGraph
89
90
91
92
-- outOfLine  	  :: CmmAGraph -> CmmAGraph
-- withUnique 	  :: (Unique -> CmmAGraph) -> CmmAGraph
-- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph

93
94
--------------------------------------------------------------------------

95
mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
96
mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
97
98
99
100
101

mkCmmIfThen e tbranch
  = withFreshLabel "end of if"     $ \endif ->
    withFreshLabel "start of then" $ \tid ->
    mkCbranch e tid endif <*>
102
103
    mkLabel tid   <*> tbranch <*> mkBranch endif <*>
    mkLabel endif
104

105
106
107
108


-- ================ IMPLEMENTATION ================--

109
mkNop                     = emptyAGraph
110
111
112
mkComment fs              = mkMiddle $ MidComment fs
mkStore  l r              = mkMiddle $ MidStore  l r

113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
-- 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

128
129
130
131
132

-- 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)
133
mkSwitch e tbl            = mkLast $ LastSwitch e tbl
134

135
136
137
138
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
139

140
141
142
-- For debugging purposes, we can stub out dead stack slots:
stackStubExpr :: Width -> CmmExpr
stackStubExpr w = CmmLit (CmmInt 0 w)
143

144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
-- 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)

164
165
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
166
167
168
copyIn :: CopyIn
copyIn oflow conv isCall area formals =
  foldr ci (init_offset, mkNop) args'
169
  where ci (reg, RegisterParam r) (n, ms) =
170
          (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
        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:
194
195
196
197
198

-- 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.
199
copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
200
  foldr co (init_offset, []) args'
201
202
203
  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)
204
        (setRA, init_offset) =
205
          case a of Young id@(BlockId _) -> -- set RA if making a call
206
                      if transfer == Call then
207
208
                        ([(CmmLit (CmmBlock id), StackParam init_offset)],
                         widthInBytes wordWidth)
209
                      else ([], 0)
210
                    Old -> ([], updfr_off)
211
        args = assignArgumentsPos conv (transfer /= Ret) cmmExprType actuals
212
213
214
        args' = foldl adjust setRA args
          where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
                adjust rst x@(_, RegisterParam _) = x : rst
215
216
217
218
219
220
221
222
223
224
225
226
227
228
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))
229
230

mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
231
mkEntry _ conv formals = copyInOflow conv False (CallArea Old) formals
232
233

lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
234
                (ByteOff -> Last) -> CmmAGraph
235
lastWithArgs transfer area conv actuals updfr_off last =
236
  let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
237
  mkMiddles copies <*> mkLast (last outArgs)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
238

239
240
-- The area created for the jump and return arguments is the same area as the
-- procedure entry.
241
242
old :: Area
old = CallArea Old
243
244
245
toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
toCall e cont updfr_off res_space arg_space =
  LastCall e cont arg_space res_space (Just updfr_off)
246
mkJump e actuals updfr_off =
247
  lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
248
mkJumpGC e actuals updfr_off =
249
  lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
250
mkForeignJump conv e actuals updfr_off =
251
  lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
252
mkReturn e actuals updfr_off =
253
  lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
254
255
    -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
mkReturnSimple actuals updfr_off =
256
  lastWithArgs Ret  old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
257
258
259
    where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord

mkFinalCall f _ actuals updfr_off =
260
  lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
261

262
mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
263

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
264
-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
265
266
267
mkCall f (callConv, retConv) results actuals updfr_off =
 pprTrace "mkCall" (ppr f <+> ppr actuals <+> ppr results <+> ppr callConv <+>
                    ppr retConv) $
268
  withFreshLabel "call successor" $ \k ->
269
    let area = CallArea $ Young k
270
271
        (off, copyin) = copyInOflow retConv False area results
        copyout = lastWithArgs Call area callConv actuals updfr_off 
272
273
                               (toCall f (Just k) updfr_off off)
    in (copyout <*> mkLabel k <*> copyin)