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