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