compiler/codeGen/StgCmmForeign.hs

   1 {-# OPTIONS -w #-}
   2 -- Lots of missing type sigs etc
   3
   4 -----------------------------------------------------------------------------
   5 --
   6 -- Code generation for foreign calls.
   7 --
   8 -- (c) The University of Glasgow 2004-2006
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module StgCmmForeign (
  13   cgForeignCall, loadThreadState, saveThreadState,
  14   emitPrimCall, emitCCall,
  15   emitSaveThreadState, -- will be needed by the Cmm parser
  16   emitLoadThreadState, -- ditto
  17   emitOpenNursery,
  18  ) where
  19
  20 #include "HsVersions.h"
  21
  22 import StgSyn
  23 import StgCmmProf
  24 import StgCmmEnv
  25 import StgCmmMonad
  26 import StgCmmUtils
  27 import StgCmmClosure
  28
  29 import BlockId
  30 import Cmm
  31 import CmmUtils
  32 import MkZipCfg
  33 import MkZipCfgCmm hiding (CmmAGraph)
  34 import Type
  35 import TysPrim
  36 import UniqSupply
  37 import CLabel
  38 import SMRep
  39 import ForeignCall
  40 import Constants
  41 import StaticFlags
  42 import FastString
  43 import Maybes
  44 import Outputable
  45 import ZipCfgCmmRep
  46
  47 import Control.Monad
  48
  49 -----------------------------------------------------------------------------
  50 -- Code generation for Foreign Calls
  51 -----------------------------------------------------------------------------
  52
  53 cgForeignCall :: [LocalReg]             -- r1,r2  where to put the results
  54               -> [ForeignHint]
  55               -> ForeignCall            -- the op
  56               -> [StgArg]               -- x,y    arguments
  57               -> FCode ()
  58 -- Emits code for an unsafe foreign call:      r1, r2 = foo( x, y, z )
  59
  60 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
  61   = do  { cmm_args <- getFCallArgs stg_args
  62         ; let (args, arg_hints) = unzip cmm_args
  63               fc = ForeignConvention cconv arg_hints result_hints
  64               (call_args, cmm_target)
  65                 = case target of
  66                    StaticTarget lbl -> (args, CmmLit (CmmLabel
  67                                                 (mkForeignLabel lbl (call_size args) False)))
  68                    DynamicTarget    ->  case args of fn:rest -> (rest, fn)
  69               call_target = ForeignTarget cmm_target fc
  70
  71         ; srt <- getSRTInfo NoSRT       -- SLPJ: Not sure what SRT
  72                                         -- is right here
  73                                         -- JD: Does it matter in the new codegen?
  74         ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
  75   where
  76         -- in the stdcall calling convention, the symbol needs @size appended
  77         -- to it, where size is the total number of bytes of arguments.  We
  78         -- attach this info to the CLabel here, and the CLabel pretty printer
  79         -- will generate the suffix when the label is printed.
  80       call_size args
  81         | StdCallConv <- cconv = Just (sum (map arg_size args))
  82         | otherwise            = Nothing
  83
  84         -- ToDo: this might not be correct for 64-bit API
  85       arg_size arg = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
  86
  87 cgForeignCall _ _ (DNCall _) _
  88   = panic "cgForeignCall: DNCall"
  89
  90 emitCCall :: [(CmmFormal,ForeignHint)]
  91           -> CmmExpr
  92           -> [(CmmActual,ForeignHint)]
  93           -> FCode ()
  94 emitCCall hinted_results fn hinted_args
  95   = emitForeignCall PlayRisky results (ForeignTarget fn fc) args
  96                     NoC_SRT -- No SRT b/c we PlayRisky
  97                     CmmMayReturn
  98   where
  99     (args, arg_hints) = unzip hinted_args
 100     (results, result_hints) = unzip hinted_results
 101     target = ForeignTarget fn fc
 102     fc = ForeignConvention CCallConv arg_hints result_hints
 103
 104
 105 emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
 106 emitPrimCall res op args
 107   = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
 108
 109 -- alternative entry point, used by CmmParse
 110 emitForeignCall
 111         :: Safety
 112         -> CmmFormals           -- where to put the results
 113         -> MidCallTarget        -- the op
 114         -> CmmActuals           -- arguments
 115         -> C_SRT                -- the SRT of the calls continuation
 116         -> CmmReturnInfo        -- This can say "never returns"
 117                                 --   only RTS procedures do this
 118         -> FCode ()
 119 emitForeignCall safety results target args _srt ret
 120   | not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do
 121     let (caller_save, caller_load) = callerSaveVolatileRegs
 122     updfr_off <- getUpdFrameOff
 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 (ForeignTarget expr conv) = do
 149   tmp <- maybe_assign_temp expr
 150   return (ForeignTarget tmp conv)
 151 load_target_into_temp other_target@(PrimTarget _) =
 152   return other_target
 153
 154 maybe_assign_temp e
 155   | hasNoGlobalRegs e = return e
 156   | otherwise         = do
 157         -- don't use assignTemp, it uses its own notion of "trivial"
 158         -- expressions, which are wrong here.
 159         -- this is a NonPtr because it only duplicates an existing
 160         reg <- newTemp (cmmExprType e) --TODO FIXME NOW
 161         emit (mkAssign (CmmLocal reg) e)
 162         return (CmmReg (CmmLocal reg))
 163
 164 -- -----------------------------------------------------------------------------
 165 -- Save/restore the thread state in the TSO
 166
 167 -- This stuff can't be done in suspendThread/resumeThread, because it
 168 -- refers to global registers which aren't available in the C world.
 169
 170 saveThreadState :: CmmAGraph
 171 saveThreadState =
 172   -- CurrentTSO->sp = Sp;
 173   mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
 174   <*> closeNursery
 175   -- and save the current cost centre stack in the TSO when profiling:
 176   <*> if opt_SccProfilingOn then
 177         mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
 178       else mkNop
 179
 180 emitSaveThreadState :: BlockId -> FCode ()
 181 emitSaveThreadState bid = do
 182   -- CurrentTSO->sp = Sp;
 183   emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
 184                  (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
 185   emit closeNursery
 186   -- and save the current cost centre stack in the TSO when profiling:
 187   when opt_SccProfilingOn $
 188         emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 189
 190    -- CurrentNursery->free = Hp+1;
 191 closeNursery :: CmmAGraph
 192 closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
 193
 194 loadThreadState :: LocalReg -> CmmAGraph
 195 loadThreadState tso = do
 196   -- tso <- newTemp gcWord -- TODO FIXME NOW
 197   catAGraphs [
 198         -- tso = CurrentTSO;
 199         mkAssign (CmmLocal tso) stgCurrentTSO,
 200         -- Sp = tso->sp;
 201         mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
 202                               bWord),
 203         -- SpLim = tso->stack + RESERVED_STACK_WORDS;
 204         mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
 205                                     rESERVED_STACK_WORDS),
 206         openNursery,
 207         -- and load the current cost centre stack from the TSO when profiling:
 208         if opt_SccProfilingOn then
 209           mkStore curCCSAddr
 210                   (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
 211         else mkNop]
 212 emitLoadThreadState :: LocalReg -> FCode ()
 213 emitLoadThreadState tso = emit $ loadThreadState tso
 214
 215 openNursery :: CmmAGraph
 216 openNursery = catAGraphs [
 217         -- Hp = CurrentNursery->free - 1;
 218         mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
 219
 220         -- HpLim = CurrentNursery->start +
 221         --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
 222         mkAssign hpLim
 223             (cmmOffsetExpr
 224                 (CmmLoad nursery_bdescr_start bWord)
 225                 (cmmOffset
 226                   (CmmMachOp mo_wordMul [
 227                     CmmMachOp (MO_SS_Conv W32 wordWidth)
 228                       [CmmLoad nursery_bdescr_blocks b32],
 229                     CmmLit (mkIntCLit bLOCK_SIZE)
 230                    ])
 231                   (-1)
 232                 )
 233             )
 234    ]
 235 emitOpenNursery :: FCode ()
 236 emitOpenNursery = emit openNursery
 237
 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    = 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             = CmmReg sp
 257 stgHp             = CmmReg hp
 258 stgCurrentTSO     = CmmReg currentTSO
 259 stgCurrentNursery = CmmReg currentNursery
 260
 261 sp                = CmmGlobal Sp
 262 spLim             = CmmGlobal SpLim
 263 hp                = CmmGlobal Hp
 264 hpLim             = CmmGlobal HpLim
 265 currentTSO        = CmmGlobal CurrentTSO
 266 currentNursery    = CmmGlobal CurrentNursery
 267
 268 -- -----------------------------------------------------------------------------
 269 -- For certain types passed to foreign calls, we adjust the actual
 270 -- value passed to the call.  For ByteArray#/Array# we pass the
 271 -- address of the actual array, not the address of the heap object.
 272
 273 getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
 274 -- (a) Drop void args
 275 -- (b) Add foreign-call shim code
 276 -- It's (b) that makes this differ from getNonVoidArgAmodes
 277
 278 getFCallArgs args
 279   = do  { mb_cmms <- mapM get args
 280         ; return (catMaybes mb_cmms) }
 281   where
 282     get arg | isVoidRep arg_rep
 283             = return Nothing
 284             | otherwise
 285             = do { cmm <- getArgAmode (NonVoid arg)
 286                  ; return (Just (add_shim arg_ty cmm, hint)) }
 287             where
 288               arg_ty  = stgArgType arg
 289               arg_rep = typePrimRep arg_ty
 290               hint    = typeForeignHint arg_ty
 291
 292 add_shim :: Type -> CmmExpr -> CmmExpr
 293 add_shim arg_ty expr
 294   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
 295   = cmmOffsetB expr arrPtrsHdrSize
 296
 297   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
 298   = cmmOffsetB expr arrWordsHdrSize
 299
 300   | otherwise = expr
 301   where
 302     tycon = tyConAppTyCon (repType arg_ty)
 303         -- should be a tycon app, since this is a foreign call