StgCmmForeign.hs 15.1 KB
Newer Older
1
2
3
4
5
6
7
8
9
-----------------------------------------------------------------------------
--
-- Code generation for foreign calls.
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module StgCmmForeign (
10
  cgForeignCall, loadThreadState, saveThreadState,
11
12
13
14
15
16
17
18
19
20
21
22
23
24
  emitPrimCall, emitCCall,
  emitSaveThreadState, -- will be needed by the Cmm parser
  emitLoadThreadState, -- ditto
  emitOpenNursery,
 ) where

#include "HsVersions.h"

import StgSyn
import StgCmmProf
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
25
import StgCmmLayout
26

27
import BlockId
28
import Cmm
29
import CmmUtils
30
31
import OldCmm ( CmmReturnInfo(..) )
import MkGraph
32
33
34
35
36
37
import Type
import TysPrim
import CLabel
import SMRep
import ForeignCall
import Constants
38
import DynFlags
39
40
import Maybes
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
41
import BasicTypes
42
43

import Control.Monad
44
import Prelude hiding( succ )
45
46
47
48
49

-----------------------------------------------------------------------------
-- Code generation for Foreign Calls
-----------------------------------------------------------------------------

50
51
52
-- | emit code for a foreign call, and return the results to the sequel.
--
cgForeignCall :: ForeignCall            -- the op
53
              -> [StgArg]               -- x,y    arguments
54
              -> Type                   -- result type
55
              -> FCode ReturnKind
56

57
cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
58
  = do  { cmm_args <- getFCallArgs stg_args
59
        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
60
61
        ; let ((call_args, arg_hints), cmm_target)
                = case target of
62
63
64
                   StaticTarget _   _      False ->
                       panic "cgForeignCall: unexpected FFI value import"
                   StaticTarget lbl mPkgId True
65
66
67
68
                     -> let labelSource
                                = case mPkgId of
                                        Nothing         -> ForeignLabelInThisPackage
                                        Just pkgId      -> ForeignLabelInPackage pkgId
69
                            size = call_size cmm_args
70
71
72
73
                        in  ( unzip cmm_args
                            , CmmLit (CmmLabel
                                        (mkForeignLabel lbl size labelSource IsFunction)))

74
                   DynamicTarget    ->  case cmm_args of
75
76
                                           (fn,_):rest -> (unzip rest, fn)
                                           [] -> panic "cgForeignCall []"
77
              fc = ForeignConvention cconv arg_hints res_hints
78
              call_target = ForeignTarget cmm_target fc
79

80
81
82
83
84
85
86
87
88
89
90
91
        -- we want to emit code for the call, and then emitReturn.
        -- However, if the sequel is AssignTo, we shortcut a little
        -- and generate a foreign call that assigns the results
        -- directly.  Otherwise we end up generating a bunch of
        -- useless "r = r" assignments, which are not merely annoying:
        -- they prevent the common block elimination from working correctly
        -- in the case of a safe foreign call.
        -- See Note [safe foreign call convention]
        --
        ; sequel <- getSequel
        ; case sequel of
            AssignTo assign_to_these _ ->
92
                emitForeignCall safety assign_to_these call_target
93
94
95
                                     call_args CmmMayReturn

            _something_else ->
96
                do { _ <- emitForeignCall safety res_regs call_target
97
98
99
100
                                     call_args CmmMayReturn
                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)
                   }
         }
101
  where
102
103
104
105
        -- in the stdcall calling convention, the symbol needs @size appended
        -- to it, where size is the total number of bytes of arguments.  We
        -- attach this info to the CLabel here, and the CLabel pretty printer
        -- will generate the suffix when the label is printed.
106
      call_size args
107
108
        | StdCallConv <- cconv = Just (sum (map arg_size args))
        | otherwise            = Nothing
109

110
        -- ToDo: this might not be correct for 64-bit API
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
      arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg)
                               wORD_SIZE

{- Note [safe foreign call convention]

The simple thing to do for a safe foreign call would be the same as an
unsafe one: just

    emitForeignCall ...
    emitReturn ...

but consider what happens in this case

   case foo x y z of
     (# s, r #) -> ...

The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]
as the result reg, and we generate

  r = foo(x,y,z) returns to L1  -- emitForeignCall
 L1:
  r = r  -- emitReturn
  goto L2
L2:
  ...

Now L1 is a proc point (by definition, it is the continuation of the
safe foreign call).  If L2 does a heap check, then L2 will also be a
proc point.

Furthermore, the stack layout algorithm has to arrange to save r
somewhere between the call and the jump to L1, which is annoying: we
would have to treat r differently from the other live variables, which
have to be saved *before* the call.

So we adopt a special convention for safe foreign calls: the results
are copied out according to the NativeReturn convention by the call,
and the continuation of the call should copyIn the results.  (The
copyOut code is actually inserted when the safe foreign call is
lowered later).  The result regs attached to the safe foreign call are
only used temporarily to hold the results before they are copied out.

We will now generate this:

  r = foo(x,y,z) returns to L1
 L1:
  r = R1  -- copyIn, inserted by mkSafeCall
  goto L2
 L2:
  ... r ...

And when the safe foreign call is lowered later (see Note [lower safe
foreign calls]) we get this:

  suspendThread()
  r = foo(x,y,z)
  resumeThread()
  R1 = r  -- copyOut, inserted by lowerSafeForeignCall
  jump L1
 L1:
  r = R1  -- copyIn, inserted by mkSafeCall
  goto L2
 L2:
  ... r ...

Now consider what happens if L2 does a heap check: the Adams
optimisation kicks in and commons up L1 with the heap-check
continuation, resulting in just one proc point instead of two. Yay!
-}

181
182

emitCCall :: [(CmmFormal,ForeignHint)]
183
184
185
          -> CmmExpr
          -> [(CmmActual,ForeignHint)]
          -> FCode ()
186
emitCCall hinted_results fn hinted_args
187
  = void $ emitForeignCall PlayRisky results target args CmmMayReturn
188
189
190
191
192
  where
    (args, arg_hints) = unzip hinted_args
    (results, result_hints) = unzip hinted_results
    target = ForeignTarget fn fc
    fc = ForeignConvention CCallConv arg_hints result_hints
193

194

195
emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
196
emitPrimCall res op args
197
  = void $ emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
198
199
200

-- alternative entry point, used by CmmParse
emitForeignCall
201
202
203
204
205
206
        :: Safety
        -> [CmmFormal]          -- where to put the results
        -> ForeignTarget        -- the op
        -> [CmmActual]          -- arguments
        -> CmmReturnInfo        -- This can say "never returns"
                                --   only RTS procedures do this
207
        -> FCode ReturnKind
Simon Marlow's avatar
Simon Marlow committed
208
emitForeignCall safety results target args _ret
209
  | not (playSafe safety) = do
210
211
    let (caller_save, caller_load) = callerSaveVolatileRegs
    emit caller_save
212
    emit $ mkUnsafeCall target results args
213
    emit caller_load
214
    return AssignedDirectly
215
216

  | otherwise = do
217
    dflags <- getDynFlags
218
    updfr_off <- getUpdFrameOff
219
    temp_target <- load_target_into_temp target
220
    k <- newLabelC
221
    let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results
222
223
224
225
226
227
228
229
230
231
232
233
234
235
       -- see Note [safe foreign call convention]
    emit $
           (    mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
                        (CmmLit (CmmBlock k))
            <*> mkLast (CmmForeignCall { tgt  = temp_target
                                       , res  = results
                                       , args = args
                                       , succ = k
                                       , updfr = updfr_off
                                       , intrbl = playInterruptible safety })
            <*> mkLabel k
            <*> copyout
           )
    return (ReturnedTo k off)
236

237

238
{-
239
--      THINK ABOUT THIS (used to happen)
240
241
242
243
244
245
246
247
248
-- we might need to load arguments into temporaries before
-- making the call, because certain global registers might
-- overlap with registers that the C calling convention uses
-- for passing arguments.
--
-- This is a HACK; really it should be done in the back end, but
-- it's easier to generate the temporaries here.
load_args_into_temps = mapM arg_assign_temp
  where arg_assign_temp (e,hint) = do
249
250
           tmp <- maybe_assign_temp e
           return (tmp,hint)
251
-}
252

253
load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
254
load_target_into_temp (ForeignTarget expr conv) = do
255
  tmp <- maybe_assign_temp expr
256
257
  return (ForeignTarget tmp conv)
load_target_into_temp other_target@(PrimTarget _) =
258
259
  return other_target

Ian Lynagh's avatar
Ian Lynagh committed
260
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
261
262
maybe_assign_temp e
  | hasNoGlobalRegs e = return e
263
264
265
  | otherwise         = do
        -- don't use assignTemp, it uses its own notion of "trivial"
        -- expressions, which are wrong here.
266
        -- this is a NonPtr because it only duplicates an existing
267
        reg <- newTemp (cmmExprType e) --TODO FIXME NOW
268
        emitAssign (CmmLocal reg) e
269
        return (CmmReg (CmmLocal reg))
270
271
272
273
274
275
276

-- -----------------------------------------------------------------------------
-- Save/restore the thread state in the TSO

-- This stuff can't be done in suspendThread/resumeThread, because it
-- refers to global registers which aren't available in the C world.

277
278
saveThreadState :: DynFlags -> CmmAGraph
saveThreadState dflags =
279
  -- CurrentTSO->stackobj->sp = Sp;
280
  mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags)) stgSp
281
282
  <*> closeNursery
  -- and save the current cost centre stack in the TSO when profiling:
283
284
  <*> if dopt Opt_SccProfilingOn dflags then
        mkStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
285
286
287
288
      else mkNop

emitSaveThreadState :: BlockId -> FCode ()
emitSaveThreadState bid = do
289
290
  dflags <- getDynFlags

291
  -- CurrentTSO->stackobj->sp = Sp;
292
  emitStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO (tso_stackobj dflags)) bWord) (stack_SP dflags))
Simon Marlow's avatar
Simon Marlow committed
293
                 (CmmStackSlot (Young bid) (widthInBytes (typeWidth gcWord)))
294
  emit closeNursery
295
  -- and save the current cost centre stack in the TSO when profiling:
296
297
  when (dopt Opt_SccProfilingOn dflags) $
        emitStore (cmmOffset stgCurrentTSO (tso_CCCS dflags)) curCCS
298
299

   -- CurrentNursery->free = Hp+1;
300
301
closeNursery :: CmmAGraph
closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
302

303
304
loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
loadThreadState dflags tso stack = do
305
  -- tso <- newTemp gcWord -- TODO FIXME NOW
306
  -- stack <- newTemp gcWord -- TODO FIXME NOW
307
  catAGraphs [
308
309
310
        -- tso = CurrentTSO;
        mkAssign (CmmLocal tso) stgCurrentTSO,
        -- stack = tso->stackobj;
311
        mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) bWord),
312
        -- Sp = stack->sp;
313
        mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) (stack_SP dflags)) bWord),
314
        -- SpLim = stack->stack + RESERVED_STACK_WORDS;
315
        mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) (stack_STACK dflags))
316
                                    rESERVED_STACK_WORDS),
317
318
        openNursery,
        -- and load the current cost centre stack from the TSO when profiling:
319
        if dopt Opt_SccProfilingOn dflags then
320
          storeCurCCS
321
            (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) ccsType)
322
        else mkNop]
323
emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
324
325
emitLoadThreadState tso stack = do dflags <- getDynFlags
                                   emit $ loadThreadState dflags tso stack
326
327
328

openNursery :: CmmAGraph
openNursery = catAGraphs [
329
        -- Hp = CurrentNursery->free - 1;
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
        mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),

        -- HpLim = CurrentNursery->start +
        --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
        mkAssign hpLim
            (cmmOffsetExpr
                (CmmLoad nursery_bdescr_start bWord)
                (cmmOffset
                  (CmmMachOp mo_wordMul [
                    CmmMachOp (MO_SS_Conv W32 wordWidth)
                      [CmmLoad nursery_bdescr_blocks b32],
                    CmmLit (mkIntCLit bLOCK_SIZE)
                   ])
                  (-1)
                )
            )
346
   ]
347
348
emitOpenNursery :: FCode ()
emitOpenNursery = emit openNursery
349

Ian Lynagh's avatar
Ian Lynagh committed
350
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
351
352
353
354
nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks

355
356
357
358
359
tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
tso_stackobj dflags = closureField dflags oFFSET_StgTSO_stackobj
tso_CCCS     dflags = closureField dflags oFFSET_StgTSO_cccs
stack_STACK  dflags = closureField dflags oFFSET_StgStack_stack
stack_SP     dflags = closureField dflags oFFSET_StgStack_sp
360

361

362
363
closureField :: DynFlags -> ByteOff -> ByteOff
closureField dflags off = off + fixedHdrSize dflags * wORD_SIZE
364

Ian Lynagh's avatar
Ian Lynagh committed
365
stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
366
367
368
stgSp             = CmmReg sp
stgHp             = CmmReg hp
stgCurrentTSO     = CmmReg currentTSO
369
370
stgCurrentNursery = CmmReg currentNursery

Ian Lynagh's avatar
Ian Lynagh committed
371
sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
372
373
374
375
376
377
sp                = CmmGlobal Sp
spLim             = CmmGlobal SpLim
hp                = CmmGlobal Hp
hpLim             = CmmGlobal HpLim
currentTSO        = CmmGlobal CurrentTSO
currentNursery    = CmmGlobal CurrentNursery
378
379
380
381
382
383
384
385

-- -----------------------------------------------------------------------------
-- For certain types passed to foreign calls, we adjust the actual
-- value passed to the call.  For ByteArray#/Array# we pass the
-- address of the actual array, not the address of the heap object.

getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
-- (a) Drop void args
386
-- (b) Add foreign-call shim code
387
388
389
-- It's (b) that makes this differ from getNonVoidArgAmodes

getFCallArgs args
390
391
  = do  { mb_cmms <- mapM get args
        ; return (catMaybes mb_cmms) }
392
  where
393
394
395
396
    get arg | isVoidRep arg_rep
            = return Nothing
            | otherwise
            = do { cmm <- getArgAmode (NonVoid arg)
397
398
                 ; dflags <- getDynFlags
                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
399
400
401
402
            where
              arg_ty  = stgArgType arg
              arg_rep = typePrimRep arg_ty
              hint    = typeForeignHint arg_ty
403

404
405
add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
add_shim dflags arg_ty expr
406
  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
407
  = cmmOffsetB expr (arrPtrsHdrSize dflags)
408
409

  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
410
  = cmmOffsetB expr (arrWordsHdrSize dflags)
411
412

  | otherwise = expr
413
  where
414
415
    UnaryRep rep_ty = repType arg_ty
    tycon           = tyConAppTyCon rep_ty
416
        -- should be a tycon app, since this is a foreign call