compiler/codeGen/StgCmmForeign.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generation for foreign calls.
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmForeign (
  10   cgForeignCall, loadThreadState, saveThreadState,
  11   emitPrimCall, emitCCall,
  12   emitSaveThreadState, -- will be needed by the Cmm parser
  13   emitLoadThreadState, -- ditto
  14   emitOpenNursery,
  15  ) where
  16
  17 #include "HsVersions.h"
  18
  19 import StgSyn
  20 import StgCmmProf
  21 import StgCmmEnv
  22 import StgCmmMonad
  23 import StgCmmUtils
  24 import StgCmmClosure
  25
  26 import BlockId
  27 import Cmm
  28 import CmmUtils
  29 import MkZipCfgCmm hiding (CmmAGraph)
  30 import Type
  31 import TysPrim
  32 import CLabel
  33 import SMRep
  34 import ForeignCall
  35 import Constants
  36 import StaticFlags
  37 import Maybes
  38 import Outputable
  39 import ZipCfgCmmRep
  40 import BasicTypes
  41
  42 import Control.Monad
  43
  44 -----------------------------------------------------------------------------
  45 -- Code generation for Foreign Calls
  46 -----------------------------------------------------------------------------
  47
  48 cgForeignCall :: [LocalReg]             -- r1,r2  where to put the results
  49               -> [ForeignHint]
  50               -> ForeignCall            -- the op
  51               -> [StgArg]               -- x,y    arguments
  52               -> FCode ()
  53 -- Emits code for an unsafe foreign call:      r1, r2 = foo( x, y, z )
  54
  55 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
  56   = do  { cmm_args <- getFCallArgs stg_args
  57         ; let ((call_args, arg_hints), cmm_target)
  58                 = case target of
  59                     StaticTarget lbl ->
  60                       (unzip cmm_args,
  61                        CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args)
  62                                                         False IsFunction)))
  63                     DynamicTarget    ->  case cmm_args of
  64                                            (fn,_):rest -> (unzip rest, fn)
  65                                            [] -> panic "cgForeignCall []"
  66               fc = ForeignConvention cconv arg_hints result_hints
  67               call_target = ForeignTarget cmm_target fc
  68
  69         ; srt <- getSRTInfo NoSRT        -- SLPJ: Not sure what SRT
  70                                         -- is right here
  71                                         -- JD: Does it matter in the new codegen?
  72         ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
  73   where
  74         -- in the stdcall calling convention, the symbol needs @size appended
  75         -- to it, where size is the total number of bytes of arguments.  We
  76         -- attach this info to the CLabel here, and the CLabel pretty printer
  77         -- will generate the suffix when the label is printed.
  78       call_size args
  79         | StdCallConv <- cconv = Just (sum (map arg_size args))
  80         | otherwise            = Nothing
  81
  82         -- ToDo: this might not be correct for 64-bit API
  83       arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
  84
  85 emitCCall :: [(CmmFormal,ForeignHint)]
  86           -> CmmExpr
  87           -> [(CmmActual,ForeignHint)]
  88           -> FCode ()
  89 emitCCall hinted_results fn hinted_args
  90   = emitForeignCall PlayRisky results target args
  91                     NoC_SRT -- No SRT b/c we PlayRisky
  92                     CmmMayReturn
  93   where
  94     (args, arg_hints) = unzip hinted_args
  95     (results, result_hints) = unzip hinted_results
  96     target = ForeignTarget fn fc
  97     fc = ForeignConvention CCallConv arg_hints result_hints
  98
  99
 100 emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
 101 emitPrimCall res op args
 102   = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
 103
 104 -- alternative entry point, used by CmmParse
 105 emitForeignCall
 106         :: Safety
 107         -> CmmFormals           -- where to put the results
 108         -> MidCallTarget        -- the op
 109         -> CmmActuals           -- arguments
 110         -> C_SRT                -- the SRT of the calls continuation
 111         -> CmmReturnInfo        -- This can say "never returns"
 112                                 --   only RTS procedures do this
 113         -> FCode ()
 114 emitForeignCall safety results target args _srt _ret
 115   | not (playSafe safety) = do
 116     let (caller_save, caller_load) = callerSaveVolatileRegs
 117     emit caller_save
 118     emit $ mkUnsafeCall target results args
 119     emit caller_load
 120
 121   | otherwise = do
 122     updfr_off <- getUpdFrameOff
 123     temp_target <- load_target_into_temp target
 124     emit $ mkSafeCall temp_target results args updfr_off
 125
 126
 127 {-
 128 --      THINK ABOUT THIS (used to happen)
 129 -- we might need to load arguments into temporaries before
 130 -- making the call, because certain global registers might
 131 -- overlap with registers that the C calling convention uses
 132 -- for passing arguments.
 133 --
 134 -- This is a HACK; really it should be done in the back end, but
 135 -- it's easier to generate the temporaries here.
 136 load_args_into_temps = mapM arg_assign_temp
 137   where arg_assign_temp (e,hint) = do
 138            tmp <- maybe_assign_temp e
 139            return (tmp,hint)
 140 -}
 141
 142 load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
 143 load_target_into_temp (ForeignTarget expr conv) = do
 144   tmp <- maybe_assign_temp expr
 145   return (ForeignTarget tmp conv)
 146 load_target_into_temp other_target@(PrimTarget _) =
 147   return other_target
 148
 149 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
 150 maybe_assign_temp e
 151   | hasNoGlobalRegs e = return e
 152   | otherwise         = do
 153         -- don't use assignTemp, it uses its own notion of "trivial"
 154         -- expressions, which are wrong here.
 155         -- this is a NonPtr because it only duplicates an existing
 156         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
 157         emit (mkAssign (CmmLocal reg) e)
 158         return (CmmReg (CmmLocal reg))
 159
 160 -- -----------------------------------------------------------------------------
 161 -- Save/restore the thread state in the TSO
 162
 163 -- This stuff can't be done in suspendThread/resumeThread, because it
 164 -- refers to global registers which aren't available in the C world.
 165
 166 saveThreadState :: CmmAGraph
 167 saveThreadState =
 168   -- CurrentTSO->sp = Sp;
 169   mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 170   <*> closeNursery
 171   -- and save the current cost centre stack in the TSO when profiling:
 172   <*> if opt_SccProfilingOn then
 173         mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
 174       else mkNop
 175
 176 emitSaveThreadState :: BlockId -> FCode ()
 177 emitSaveThreadState bid = do
 178   -- CurrentTSO->sp = Sp;
 179   emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
 180                  (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
 181   emit closeNursery
 182   -- and save the current cost centre stack in the TSO when profiling:
 183   when opt_SccProfilingOn $
 184         emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 185
 186    -- CurrentNursery->free = Hp+1;
 187 closeNursery :: CmmAGraph
 188 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 189
 190 loadThreadState :: LocalReg -> CmmAGraph
 191 loadThreadState tso = do
 192   -- tso <- newTemp gcWord -- TODO FIXME NOW
 193   catAGraphs [
 194         -- tso = CurrentTSO;
 195         mkAssign (CmmLocal tso) stgCurrentTSO,
 196         -- Sp = tso->sp;
 197         mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 198                               bWord),
 199         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 200         mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 201                                     rESERVED_STACK_WORDS),
 202         openNursery,
 203         -- and load the current cost centre stack from the TSO when profiling:
 204         if opt_SccProfilingOn then
 205           mkStore curCCSAddr
 206                   (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
 207         else mkNop]
 208 emitLoadThreadState :: LocalReg -> FCode ()
 209 emitLoadThreadState tso = emit $ loadThreadState tso
 210
 211 openNursery :: CmmAGraph
 212 openNursery = catAGraphs [
 213         -- Hp = CurrentNursery->free - 1;
 214         mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
 215
 216         -- HpLim = CurrentNursery->start +
 217         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 218         mkAssign hpLim
 219             (cmmOffsetExpr
 220                 (CmmLoad nursery_bdescr_start bWord)
 221                 (cmmOffset
 222                   (CmmMachOp mo_wordMul [
 223                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 224                       [CmmLoad nursery_bdescr_blocks b32],
 225                     CmmLit (mkIntCLit bLOCK_SIZE)
 226                    ])
 227                   (-1)
 228                 )
 229             )
 230    ]
 231 emitOpenNursery :: FCode ()
 232 emitOpenNursery = emit openNursery
 233
 234 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
 235 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 236 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 237 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 238
 239 tso_SP, tso_STACK, tso_CCCS :: ByteOff
 240 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 241 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 242 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 243
 244 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 245 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 246 tsoFieldB :: ByteOff -> ByteOff
 247 tsoFieldB off
 248   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 249   | otherwise          = off + fixedHdrSize * wORD_SIZE
 250
 251 tsoProfFieldB :: ByteOff -> ByteOff
 252 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 253
 254 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 255 stgSp             = CmmReg sp
 256 stgHp             = CmmReg hp
 257 stgCurrentTSO     = CmmReg currentTSO
 258 stgCurrentNursery = CmmReg currentNursery
 259
 260 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
 261 sp                = CmmGlobal Sp
 262 spLim             = CmmGlobal SpLim
 263 hp                = CmmGlobal Hp
 264 hpLim             = CmmGlobal HpLim
 265 currentTSO        = CmmGlobal CurrentTSO
 266 currentNursery    = CmmGlobal CurrentNursery
 267
 268 -- -----------------------------------------------------------------------------
 269 -- For certain types passed to foreign calls, we adjust the actual
 270 -- value passed to the call.  For ByteArray#/Array# we pass the
 271 -- address of the actual array, not the address of the heap object.
 272
 273 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
 274 -- (a) Drop void args
 275 -- (b) Add foreign-call shim code
 276 -- It's (b) that makes this differ from getNonVoidArgAmodes
 277
 278 getFCallArgs args
 279   = do  { mb_cmms <- mapM get args
 280         ; return (catMaybes mb_cmms) }
 281   where
 282     get arg | isVoidRep arg_rep
 283             = return Nothing
 284             | otherwise
 285             = do { cmm <- getArgAmode (NonVoid arg)
 286                  ; return (Just (add_shim arg_ty cmm, hint)) }
 287             where
 288               arg_ty  = stgArgType arg
 289               arg_rep = typePrimRep arg_ty
 290               hint    = typeForeignHint arg_ty
 291
 292 add_shim :: Type -> CmmExpr -> CmmExpr
 293 add_shim arg_ty expr
 294   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 295   = cmmOffsetB expr arrPtrsHdrSize
 296
 297   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 298   = cmmOffsetB expr arrWordsHdrSize
 299
 300   | otherwise = expr
 301   where
 302     tycon = tyConAppTyCon (repType arg_ty)
 303         -- should be a tycon app, since this is a foreign call