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