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