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 cgForeignCall _ _ (DNCall _) _
  86   = panic "cgForeignCall: DNCall"
  87
  88 emitCCall :: [(CmmFormal,ForeignHint)]
  89           -> CmmExpr
  90           -> [(CmmActual,ForeignHint)]
  91           -> FCode ()
  92 emitCCall hinted_results fn hinted_args
  93   = emitForeignCall PlayRisky results target args
  94                     NoC_SRT -- No SRT b/c we PlayRisky
  95                     CmmMayReturn
  96   where
  97     (args, arg_hints) = unzip hinted_args
  98     (results, result_hints) = unzip hinted_results
  99     target = ForeignTarget fn fc
 100     fc = ForeignConvention CCallConv arg_hints result_hints
 101
 102
 103 emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
 104 emitPrimCall res op args
 105   = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
 106
 107 -- alternative entry point, used by CmmParse
 108 emitForeignCall
 109         :: Safety
 110         -> CmmFormals           -- where to put the results
 111         -> MidCallTarget        -- the op
 112         -> CmmActuals           -- arguments
 113         -> C_SRT                -- the SRT of the calls continuation
 114         -> CmmReturnInfo        -- This can say "never returns"
 115                                 --   only RTS procedures do this
 116         -> FCode ()
 117 emitForeignCall safety results target args _srt _ret
 118   | not (playSafe safety) = do
 119     let (caller_save, caller_load) = callerSaveVolatileRegs
 120     emit caller_save
 121     emit $ mkUnsafeCall target results args
 122     emit caller_load
 123
 124   | otherwise = do
 125     updfr_off <- getUpdFrameOff
 126     temp_target <- load_target_into_temp target
 127     emit $ mkSafeCall temp_target results args updfr_off
 128
 129
 130 {-
 131 --      THINK ABOUT THIS (used to happen)
 132 -- we might need to load arguments into temporaries before
 133 -- making the call, because certain global registers might
 134 -- overlap with registers that the C calling convention uses
 135 -- for passing arguments.
 136 --
 137 -- This is a HACK; really it should be done in the back end, but
 138 -- it's easier to generate the temporaries here.
 139 load_args_into_temps = mapM arg_assign_temp
 140   where arg_assign_temp (e,hint) = do
 141            tmp <- maybe_assign_temp e
 142            return (tmp,hint)
 143 -}
 144
 145 load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
 146 load_target_into_temp (ForeignTarget expr conv) = do
 147   tmp <- maybe_assign_temp expr
 148   return (ForeignTarget tmp conv)
 149 load_target_into_temp other_target@(PrimTarget _) =
 150   return other_target
 151
 152 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
 153 maybe_assign_temp e
 154   | hasNoGlobalRegs e = return e
 155   | otherwise         = do
 156         -- don't use assignTemp, it uses its own notion of "trivial"
 157         -- expressions, which are wrong here.
 158         -- this is a NonPtr because it only duplicates an existing
 159         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
 160         emit (mkAssign (CmmLocal reg) e)
 161         return (CmmReg (CmmLocal reg))
 162
 163 -- -----------------------------------------------------------------------------
 164 -- Save/restore the thread state in the TSO
 165
 166 -- This stuff can't be done in suspendThread/resumeThread, because it
 167 -- refers to global registers which aren't available in the C world.
 168
 169 saveThreadState :: CmmAGraph
 170 saveThreadState =
 171   -- CurrentTSO->sp = Sp;
 172   mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 173   <*> closeNursery
 174   -- and save the current cost centre stack in the TSO when profiling:
 175   <*> if opt_SccProfilingOn then
 176         mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
 177       else mkNop
 178
 179 emitSaveThreadState :: BlockId -> FCode ()
 180 emitSaveThreadState bid = do
 181   -- CurrentTSO->sp = Sp;
 182   emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
 183                  (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
 184   emit closeNursery
 185   -- and save the current cost centre stack in the TSO when profiling:
 186   when opt_SccProfilingOn $
 187         emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 188
 189    -- CurrentNursery->free = Hp+1;
 190 closeNursery :: CmmAGraph
 191 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 192
 193 loadThreadState :: LocalReg -> CmmAGraph
 194 loadThreadState tso = do
 195   -- tso <- newTemp gcWord -- TODO FIXME NOW
 196   catAGraphs [
 197         -- tso = CurrentTSO;
 198         mkAssign (CmmLocal tso) stgCurrentTSO,
 199         -- Sp = tso->sp;
 200         mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 201                               bWord),
 202         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 203         mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 204                                     rESERVED_STACK_WORDS),
 205         openNursery,
 206         -- and load the current cost centre stack from the TSO when profiling:
 207         if opt_SccProfilingOn then
 208           mkStore curCCSAddr
 209                   (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
 210         else mkNop]
 211 emitLoadThreadState :: LocalReg -> FCode ()
 212 emitLoadThreadState tso = emit $ loadThreadState tso
 213
 214 openNursery :: CmmAGraph
 215 openNursery = catAGraphs [
 216         -- Hp = CurrentNursery->free - 1;
 217         mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
 218
 219         -- HpLim = CurrentNursery->start +
 220         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 221         mkAssign hpLim
 222             (cmmOffsetExpr
 223                 (CmmLoad nursery_bdescr_start bWord)
 224                 (cmmOffset
 225                   (CmmMachOp mo_wordMul [
 226                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 227                       [CmmLoad nursery_bdescr_blocks b32],
 228                     CmmLit (mkIntCLit bLOCK_SIZE)
 229                    ])
 230                   (-1)
 231                 )
 232             )
 233    ]
 234 emitOpenNursery :: FCode ()
 235 emitOpenNursery = emit openNursery
 236
 237 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
 238 nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
 239 nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
 240 nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
 241
 242 tso_SP, tso_STACK, tso_CCCS :: ByteOff
 243 tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
 244 tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
 245 tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
 246
 247 -- The TSO struct has a variable header, and an optional StgTSOProfInfo in
 248 -- the middle.  The fields we're interested in are after the StgTSOProfInfo.
 249 tsoFieldB :: ByteOff -> ByteOff
 250 tsoFieldB off
 251   | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
 252   | otherwise          = off + fixedHdrSize * wORD_SIZE
 253
 254 tsoProfFieldB :: ByteOff -> ByteOff
 255 tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
 256
 257 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
 258 stgSp             = CmmReg sp
 259 stgHp             = CmmReg hp
 260 stgCurrentTSO     = CmmReg currentTSO
 261 stgCurrentNursery = CmmReg currentNursery
 262
 263 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
 264 sp                = CmmGlobal Sp
 265 spLim             = CmmGlobal SpLim
 266 hp                = CmmGlobal Hp
 267 hpLim             = CmmGlobal HpLim
 268 currentTSO        = CmmGlobal CurrentTSO
 269 currentNursery    = CmmGlobal CurrentNursery
 270
 271 -- -----------------------------------------------------------------------------
 272 -- For certain types passed to foreign calls, we adjust the actual
 273 -- value passed to the call.  For ByteArray#/Array# we pass the
 274 -- address of the actual array, not the address of the heap object.
 275
 276 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
 277 -- (a) Drop void args
 278 -- (b) Add foreign-call shim code
 279 -- It's (b) that makes this differ from getNonVoidArgAmodes
 280
 281 getFCallArgs args
 282   = do  { mb_cmms <- mapM get args
 283         ; return (catMaybes mb_cmms) }
 284   where
 285     get arg | isVoidRep arg_rep
 286             = return Nothing
 287             | otherwise
 288             = do { cmm <- getArgAmode (NonVoid arg)
 289                  ; return (Just (add_shim arg_ty cmm, hint)) }
 290             where
 291               arg_ty  = stgArgType arg
 292               arg_rep = typePrimRep arg_ty
 293               hint    = typeForeignHint arg_ty
 294
 295 add_shim :: Type -> CmmExpr -> CmmExpr
 296 add_shim arg_ty expr
 297   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 298   = cmmOffsetB expr arrPtrsHdrSize
 299
 300   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 301   = cmmOffsetB expr arrWordsHdrSize
 302
 303   | otherwise = expr
 304   where
 305     tycon = tyConAppTyCon (repType arg_ty)
 306         -- should be a tycon app, since this is a foreign call