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