ghc/compiler/nativeGen/StixPrim.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixPrim ( amodeToStix, amodeToStix', foreignCallCode )
   7 where
   8
   9 #include "HsVersions.h"
  10
  11 -- import MachMisc
  12 import Stix
  13
  14 import PprAbsC          ( pprAmode )
  15 import AbsCSyn          hiding ( spRel )
  16 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  17 import SMRep            ( fixedHdrSize )
  18 import Literal          ( Literal(..), word2IntLit )
  19 import MachOp           ( MachOp(..) )
  20 import PrimRep          ( PrimRep(..), getPrimRepSizeInBytes )
  21 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  22 import Constants        ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
  23                           rESERVED_STACK_WORDS )
  24 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  25                           mkMAP_FROZEN_infoLabel,
  26                           mkForeignLabel )
  27 import ForeignCall      ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
  28                           CCallConv(..), playSafe, playThreadSafe )
  29 import Outputable
  30 import Util             ( notNull )
  31 import FastString
  32 import FastTypes
  33
  34 #include "NCG.h"
  35 \end{code}
  36
  37 The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts.
  38
  39 \begin{code}
  40 foreignCallCode
  41     :: [CAddrMode]      -- results
  42     -> ForeignCall      -- op
  43     -> [CAddrMode]      -- args
  44     -> UniqSM StixStmtList
  45 \end{code}
  46
  47 %************************************************************************
  48 %*                                                                      *
  49 \subsubsection{Code for foreign calls}
  50 %*                                                                      *
  51 %************************************************************************
  52
  53 First, the dreaded @ccall@.
  54
  55 Usually, this compiles to an assignment, but when the left-hand side
  56 is empty, we just perform the call and ignore the result.
  57
  58 ToDo: saving/restoring of volatile regs around ccalls.
  59
  60 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
  61 rather than inheriting the calling convention of the thing which we're really
  62 calling.
  63
  64 \begin{code}
  65 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
  66
  67   | not (playSafe safety)
  68   = returnUs (\xs -> ccall : xs)
  69
  70   | otherwise
  71   = save_thread_state `thenUs` \ save ->
  72     load_thread_state `thenUs` \ load ->
  73     getUniqueUs       `thenUs` \ uniq ->
  74     let
  75        id  = StixTemp (StixVReg uniq IntRep)
  76
  77        is_threadSafe
  78         | playThreadSafe safety = 1
  79         | otherwise             = 0
  80
  81        suspend = StAssignReg IntRep id
  82                  (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv
  83                          IntRep [StReg stgBaseReg, StInt is_threadSafe ])
  84        resume  = StVoidable
  85                  (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv
  86                          VoidRep [StReg id, StInt is_threadSafe ])
  87     in
  88     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  89
  90   where
  91     (cargs, stix_target)
  92         = case ctarget of
  93              StaticTarget nm -> (rhs, Left nm)
  94              DynamicTarget |  notNull rhs -- an assertion
  95                            -> (tail rhs, Right (amodeToStix (head rhs)))
  96
  97     stix_args = map amodeToStix' cargs
  98
  99     ccall = case lhs of
 100       []    -> StVoidable (StCall stix_target cconv VoidRep stix_args)
 101       [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
 102             where
 103                lhs' = amodeToStix lhs
 104                pk   = case getAmodeRep lhs of
 105                         FloatRep  -> FloatRep
 106                         DoubleRep -> DoubleRep
 107                         Int64Rep  -> Int64Rep
 108                         Word64Rep -> Word64Rep
 109                         other     -> IntRep
 110
 111 -- a bit late to catch this here..
 112 foreignCallCode _ DNCall{} _
 113  = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
 114 \end{code}
 115
 116 %************************************************************************
 117 %*                                                                      *
 118 \subsubsection{Code for @CAddrMode@s}
 119 %*                                                                      *
 120 %************************************************************************
 121
 122 When a character is fetched from a mixed type location, we have to do
 123 an extra cast.  This is reflected in amodeCode', which is for rhs
 124 amodes that might possibly need the extra cast.
 125
 126 \begin{code}
 127 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
 128
 129 amodeToStix'{-'-} am@(CVal rr CharRep)
 130   | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
 131   | otherwise        = amodeToStix am
 132 amodeToStix' am
 133   = amodeToStix am
 134
 135 -----------
 136 amodeToStix am@(CVal rr CharRep)
 137   | mixedTypeLocn am
 138   = StInd IntRep (amodeToStix (CAddr rr))
 139
 140 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 141
 142 amodeToStix (CAddr (SpRel off))
 143   = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
 144
 145 amodeToStix (CAddr (HpRel off))
 146   = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
 147
 148 amodeToStix (CAddr (NodeRel off))
 149   = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
 150
 151 amodeToStix (CAddr (CIndex base off pk))
 152   = StIndex pk (amodeToStix base) (amodeToStix off)
 153
 154 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 155 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
 156
 157 amodeToStix (CLbl      lbl _) = StCLbl lbl
 158
 159  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 160
 161 amodeToStix (CCharLike (CLit (MachChar c)))
 162   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 163   where
 164     off = charLikeSize * (c - mIN_CHARLIKE)
 165
 166 amodeToStix (CCharLike x)
 167   = panic "amodeToStix.CCharLike"
 168
 169 amodeToStix (CIntLike (CLit (MachInt i)))
 170   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 171   where
 172     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 173
 174 amodeToStix (CIntLike x)
 175   = panic "amodeToStix.CIntLike"
 176
 177 amodeToStix (CLit core)
 178   = case core of
 179       MachChar c     -> StInt (toInteger c)
 180       MachStr s      -> StString s
 181       MachNullAddr   -> StInt 0
 182       MachInt i      -> StInt i
 183       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 184                                                        -- dreadful, but rare.
 185       MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
 186       MachLabel l _        -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 187       MachFloat d    -> StFloat d
 188       MachDouble d   -> StDouble d
 189       _ -> panic "amodeToStix:core literal"
 190
 191 amodeToStix (CMacroExpr _ macro [arg])
 192   = let
 193         arg_amode = amodeToStix arg
 194     in
 195     case macro of
 196       ENTRY_CODE -> arg_amode
 197       ARG_TAG    -> arg_amode -- just an integer no. of words
 198       GET_TAG    ->
 199 #ifdef WORDS_BIGENDIAN
 200                     StMachOp MO_Nat_And
 201                         [StInd WordRep (StIndex PtrRep arg_amode
 202                                                 (StInt (toInteger (-1)))),
 203                          StInt 65535]
 204 #else
 205                     StMachOp MO_Nat_Shr
 206                         [StInd WordRep (StIndex PtrRep arg_amode
 207                                                 (StInt (toInteger (-1)))),
 208                          StInt 16]
 209 #endif
 210       BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
 211       PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
 212       ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
 213
 214
 215 amodeToStix other
 216    = pprPanic "StixPrim.amodeToStix" (pprAmode other)
 217 \end{code}
 218
 219 Sizes of the CharLike and IntLike closures that are arranged as arrays
 220 in the data segment.  (These are in bytes.)
 221
 222 \begin{code}
 223 -- The INTLIKE base pointer
 224
 225 iNTLIKE_closure :: StixExpr
 226 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 227
 228 -- The CHARLIKE base
 229
 230 cHARLIKE_closure :: StixExpr
 231 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 232
 233 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 234
 235 -- these are the sizes of charLike and intLike closures, in _bytes_.
 236 charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
 237 intLikeSize  = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
 238 \end{code}
 239
 240
 241 \begin{code}
 242 save_thread_state
 243    = getUniqueUs   `thenUs` \ tso_uq ->
 244      let tso = StixTemp (StixVReg tso_uq PtrRep) in
 245      returnUs (\xs ->
 246         StAssignReg PtrRep tso (StReg stgCurrentTSO)
 247         : StAssignMem PtrRep
 248              (StMachOp MO_Nat_Add
 249                        [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
 250              (StReg stgSp)
 251         : StAssignMem PtrRep
 252              (StMachOp MO_Nat_Add
 253                        [StReg stgCurrentNursery,
 254                         StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
 255              (StMachOp MO_Nat_Add
 256                        [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
 257         : xs
 258      )
 259
 260 load_thread_state
 261    = getUniqueUs   `thenUs` \ tso_uq ->
 262      let tso = StixTemp (StixVReg tso_uq PtrRep) in
 263      returnUs (\xs ->
 264         StAssignReg PtrRep tso (StReg stgCurrentTSO)
 265         : StAssignReg PtrRep
 266              stgSp
 267              (StInd PtrRep
 268                   (StMachOp MO_Nat_Add
 269                             [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 270         : StAssignReg PtrRep
 271              stgSpLim
 272              (StMachOp MO_Nat_Add
 273                        [StReg tso,
 274                         StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 275                                           *BYTES_PER_WORD))])
 276         : StAssignReg PtrRep
 277              stgHp
 278              (StMachOp MO_Nat_Sub
 279                        [StInd PtrRep
 280                               (StMachOp MO_Nat_Add
 281                                         [StReg stgCurrentNursery,
 282                                          StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 283                         StInt (toInteger (1 * BYTES_PER_WORD))
 284                        ])
 285         : StAssignReg PtrRep
 286              stgHpLim
 287              (StIndex Word8Rep
 288                 (StInd PtrRep
 289                        (StIndex PtrRep (StReg stgCurrentNursery)
 290                                        (StInt (toInteger BDESCR_START))
 291                        )
 292                 )
 293                 (StMachOp MO_Nat_Sub
 294                    [StMachOp MO_NatU_Mul
 295                       [StInd WordRep
 296                              (StIndex PtrRep (StReg stgCurrentNursery)
 297                                              (StInt (toInteger BDESCR_BLOCKS))),
 298                        StInt (toInteger bLOCK_SIZE{-in bytes-})
 299                       ],
 300                       StInt (1 * BYTES_PER_WORD)
 301                    ]
 302                 )
 303
 304              )
 305
 306         : xs
 307      )
 308 \end{code}