ghc/compiler/nativeGen/StixPrim.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixPrim ( primCode, amodeToStix, amodeToStix' ) where
   7
   8 #include "HsVersions.h"
   9
  10 import MachMisc
  11 import Stix
  12 import StixInteger
  13
  14 import AbsCSyn          hiding ( spRel )
  15 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  16 import SMRep            ( fixedHdrSize )
  17 import Literal          ( Literal(..), word2IntLit )
  18 import PrimOp           ( PrimOp(..), CCall(..), CCallTarget(..) )
  19 import PrimRep          ( PrimRep(..), getPrimRepSizeInBytes )
  20 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  21 import Constants        ( mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
  22                           rESERVED_STACK_WORDS )
  23 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  24                           mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
  25                           mkForeignLabel )
  26 import CallConv         ( cCallConv )
  27 import Outputable
  28 import FastTypes
  29
  30 #include "NCG.h"
  31 \end{code}
  32
  33 The main honcho here is primCode, which handles the guts of COpStmts.
  34
  35 \begin{code}
  36 primCode
  37     :: [CAddrMode]      -- results
  38     -> PrimOp           -- op
  39     -> [CAddrMode]      -- args
  40     -> UniqSM StixTreeList
  41 \end{code}
  42
  43 First, the dreaded @ccall@.  We can't handle @casm@s.
  44
  45 Usually, this compiles to an assignment, but when the left-hand side
  46 is empty, we just perform the call and ignore the result.
  47
  48 btw Why not let programmer use casm to provide assembly code instead
  49 of C code?  ADR
  50
  51 The (MP) integer operations are a true nightmare.  Since we don't have
  52 a convenient abstract way of allocating temporary variables on the (C)
  53 stack, we use the space just below HpLim for the @MP_INT@ structures,
  54 and modify our heap check accordingly.
  55
  56 \begin{code}
  57 -- NB: ordering of clauses somewhere driven by
  58 -- the desire to getting sane patt-matching behavior
  59
  60 primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
  61   = gmpCompare res (sa1,da1, sa2,da2)
  62
  63 primCode [res] IntegerCmpIntOp args@[sa1,da1,ai]
  64   = gmpCompareInt res (sa1,da1,ai)
  65
  66 primCode [res] Integer2IntOp arg@[sa,da]
  67   = gmpInteger2Int res (sa,da)
  68
  69 primCode [res] Integer2WordOp arg@[sa,da]
  70   = gmpInteger2Word res (sa,da)
  71
  72 primCode [res] Int2AddrOp [arg]
  73   = simpleCoercion AddrRep res arg
  74
  75 primCode [res] Addr2IntOp [arg]
  76   = simpleCoercion IntRep res arg
  77
  78 primCode [res] Int2WordOp [arg]
  79   = simpleCoercion IntRep{-WordRep?-} res arg
  80
  81 primCode [res] Word2IntOp [arg]
  82   = simpleCoercion IntRep res arg
  83
  84 primCode [res] AddrToHValueOp [arg]
  85   = simpleCoercion PtrRep res arg
  86
  87 primCode [res] IntToInt8Op [arg]
  88   = narrowingCoercion IntRep Int8Rep res arg
  89 primCode [res] IntToInt16Op [arg]
  90   = narrowingCoercion IntRep Int16Rep res arg
  91 primCode [res] IntToInt32Op [arg]
  92   = narrowingCoercion IntRep Int32Rep res arg
  93
  94 primCode [res] WordToWord8Op [arg]
  95   = narrowingCoercion WordRep Word8Rep res arg
  96 primCode [res] WordToWord16Op [arg]
  97   = narrowingCoercion WordRep Word16Rep res arg
  98 primCode [res] WordToWord32Op [arg]
  99   = narrowingCoercion WordRep Word32Rep res arg
 100 \end{code}
 101
 102 \begin{code}
 103 primCode [res] SameMutableArrayOp args
 104   = let
 105         compare = StPrim AddrEqOp (map amodeToStix args)
 106         assign = StAssign IntRep (amodeToStix res) compare
 107     in
 108     returnUs (\xs -> assign : xs)
 109
 110 primCode res@[_] SameMutableByteArrayOp args
 111   = primCode res SameMutableArrayOp args
 112
 113 primCode res@[_] SameMutVarOp args
 114   = primCode res SameMutableArrayOp args
 115 \end{code}
 116
 117 \begin{code}
 118 primCode res@[_] SameMVarOp args
 119   = primCode res SameMutableArrayOp args
 120
 121 -- #define isEmptyMVarzh(r,a) \
 122 --     r =(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info )
 123 primCode [res] IsEmptyMVarOp [arg]
 124    = let res'     = amodeToStix res
 125          arg'     = amodeToStix arg
 126          arg_info = StInd PtrRep arg'
 127          em_info  = StCLbl mkEMPTY_MVAR_infoLabel
 128          same     = StPrim IntEqOp [arg_info, em_info]
 129          assign   = StAssign IntRep res' same
 130      in
 131      returnUs (\xs -> assign : xs)
 132
 133 -- #define myThreadIdzh(t) (t = CurrentTSO)
 134 primCode [res] MyThreadIdOp []
 135    = let res' = amodeToStix res
 136      in  returnUs (\xs -> StAssign ThreadIdRep res' stgCurrentTSO : xs)
 137
 138 \end{code}
 139
 140 Freezing an array of pointers is a double assignment.  We fix the
 141 header of the ``new'' closure because the lhs is probably a better
 142 addressing mode for the indirection (most likely, it's a VanillaReg).
 143
 144 \begin{code}
 145
 146 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 147   = let
 148         lhs' = amodeToStix lhs
 149         rhs' = amodeToStix rhs
 150         header = StInd PtrRep lhs'
 151         assign = StAssign PtrRep lhs' rhs'
 152         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 153     in
 154     returnUs (\xs -> assign : freeze : xs)
 155
 156 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 157   = simpleCoercion PtrRep lhs rhs
 158 \end{code}
 159
 160 Returning the size of (mutable) byte arrays is just
 161 an indexing operation.
 162
 163 \begin{code}
 164 primCode [lhs] SizeofByteArrayOp [rhs]
 165   = let
 166         lhs' = amodeToStix lhs
 167         rhs' = amodeToStix rhs
 168         sz   = StIndex IntRep rhs' fixedHS
 169         assign = StAssign IntRep lhs' (StInd IntRep sz)
 170     in
 171     returnUs (\xs -> assign : xs)
 172
 173 primCode [lhs] SizeofMutableByteArrayOp [rhs]
 174   = let
 175         lhs' = amodeToStix lhs
 176         rhs' = amodeToStix rhs
 177         sz   = StIndex IntRep rhs' fixedHS
 178         assign = StAssign IntRep lhs' (StInd IntRep sz)
 179     in
 180     returnUs (\xs -> assign : xs)
 181
 182 \end{code}
 183
 184 Most other array primitives translate to simple indexing.
 185
 186 \begin{code}
 187 primCode lhs@[_] IndexArrayOp args
 188   = primCode lhs ReadArrayOp args
 189
 190 primCode [lhs] ReadArrayOp [obj, ix]
 191   = let
 192         lhs' = amodeToStix lhs
 193         obj' = amodeToStix obj
 194         ix' = amodeToStix ix
 195         base = StIndex IntRep obj' arrPtrsHS
 196         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 197     in
 198     returnUs (\xs -> assign : xs)
 199
 200 primCode [] WriteArrayOp [obj, ix, v]
 201   = let
 202         obj' = amodeToStix obj
 203         ix' = amodeToStix ix
 204         v' = amodeToStix v
 205         base = StIndex IntRep obj' arrPtrsHS
 206         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 207     in
 208     returnUs (\xs -> assign : xs)
 209
 210 primCode [] WriteForeignObjOp [obj, v]
 211   = let
 212         obj' = amodeToStix obj
 213         v' = amodeToStix v
 214         obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
 215         assign = StAssign AddrRep (StInd AddrRep obj'') v'
 216     in
 217     returnUs (\xs -> assign : xs)
 218
 219 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 220 primCode ls IndexByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 221 primCode ls IndexByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 222 primCode ls IndexByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 223 primCode ls IndexByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 224 primCode ls IndexByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 225 primCode ls IndexByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 226 primCode ls IndexByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 227 primCode ls IndexByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 228 primCode ls IndexByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 229 primCode ls IndexByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 230 primCode ls IndexByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 231 primCode ls IndexByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 232 primCode ls IndexByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 233 primCode ls IndexByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 234 primCode ls IndexByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 235 primCode ls IndexByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 236
 237 primCode ls ReadByteArrayOp_Char      rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 238 primCode ls ReadByteArrayOp_WideChar  rs = primCode_ReadByteArrayOp CharRep      ls rs
 239 primCode ls ReadByteArrayOp_Int       rs = primCode_ReadByteArrayOp IntRep       ls rs
 240 primCode ls ReadByteArrayOp_Word      rs = primCode_ReadByteArrayOp WordRep      ls rs
 241 primCode ls ReadByteArrayOp_Addr      rs = primCode_ReadByteArrayOp AddrRep      ls rs
 242 primCode ls ReadByteArrayOp_Float     rs = primCode_ReadByteArrayOp FloatRep     ls rs
 243 primCode ls ReadByteArrayOp_Double    rs = primCode_ReadByteArrayOp DoubleRep    ls rs
 244 primCode ls ReadByteArrayOp_StablePtr rs = primCode_ReadByteArrayOp StablePtrRep ls rs
 245 primCode ls ReadByteArrayOp_Int8      rs = primCode_ReadByteArrayOp Int8Rep      ls rs
 246 primCode ls ReadByteArrayOp_Int16     rs = primCode_ReadByteArrayOp Int16Rep     ls rs
 247 primCode ls ReadByteArrayOp_Int32     rs = primCode_ReadByteArrayOp Int32Rep     ls rs
 248 primCode ls ReadByteArrayOp_Int64     rs = primCode_ReadByteArrayOp Int64Rep     ls rs
 249 primCode ls ReadByteArrayOp_Word8     rs = primCode_ReadByteArrayOp Word8Rep     ls rs
 250 primCode ls ReadByteArrayOp_Word16    rs = primCode_ReadByteArrayOp Word16Rep    ls rs
 251 primCode ls ReadByteArrayOp_Word32    rs = primCode_ReadByteArrayOp Word32Rep    ls rs
 252 primCode ls ReadByteArrayOp_Word64    rs = primCode_ReadByteArrayOp Word64Rep    ls rs
 253
 254 primCode ls WriteByteArrayOp_Char      rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 255 primCode ls WriteByteArrayOp_WideChar  rs = primCode_WriteByteArrayOp CharRep      ls rs
 256 primCode ls WriteByteArrayOp_Int       rs = primCode_WriteByteArrayOp IntRep       ls rs
 257 primCode ls WriteByteArrayOp_Word      rs = primCode_WriteByteArrayOp WordRep      ls rs
 258 primCode ls WriteByteArrayOp_Addr      rs = primCode_WriteByteArrayOp AddrRep      ls rs
 259 primCode ls WriteByteArrayOp_Float     rs = primCode_WriteByteArrayOp FloatRep     ls rs
 260 primCode ls WriteByteArrayOp_Double    rs = primCode_WriteByteArrayOp DoubleRep    ls rs
 261 primCode ls WriteByteArrayOp_StablePtr rs = primCode_WriteByteArrayOp StablePtrRep ls rs
 262 primCode ls WriteByteArrayOp_Int8      rs = primCode_WriteByteArrayOp Int8Rep      ls rs
 263 primCode ls WriteByteArrayOp_Int16     rs = primCode_WriteByteArrayOp Int16Rep     ls rs
 264 primCode ls WriteByteArrayOp_Int32     rs = primCode_WriteByteArrayOp Int32Rep     ls rs
 265 primCode ls WriteByteArrayOp_Int64     rs = primCode_WriteByteArrayOp Int64Rep     ls rs
 266 primCode ls WriteByteArrayOp_Word8     rs = primCode_WriteByteArrayOp Word8Rep     ls rs
 267 primCode ls WriteByteArrayOp_Word16    rs = primCode_WriteByteArrayOp Word16Rep    ls rs
 268 primCode ls WriteByteArrayOp_Word32    rs = primCode_WriteByteArrayOp Word32Rep    ls rs
 269 primCode ls WriteByteArrayOp_Word64    rs = primCode_WriteByteArrayOp Word64Rep    ls rs
 270
 271 primCode ls IndexOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 272 primCode ls IndexOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 273 primCode ls IndexOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 274 primCode ls IndexOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 275 primCode ls IndexOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 276 primCode ls IndexOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 277 primCode ls IndexOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 278 primCode ls IndexOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 279 primCode ls IndexOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 280 primCode ls IndexOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 281 primCode ls IndexOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 282 primCode ls IndexOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 283 primCode ls IndexOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 284 primCode ls IndexOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 285 primCode ls IndexOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 286 primCode ls IndexOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 287
 288 primCode ls IndexOffForeignObjOp_Char      rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 289 primCode ls IndexOffForeignObjOp_WideChar  rs = primCode_IndexOffForeignObjOp CharRep      ls rs
 290 primCode ls IndexOffForeignObjOp_Int       rs = primCode_IndexOffForeignObjOp IntRep       ls rs
 291 primCode ls IndexOffForeignObjOp_Word      rs = primCode_IndexOffForeignObjOp WordRep      ls rs
 292 primCode ls IndexOffForeignObjOp_Addr      rs = primCode_IndexOffForeignObjOp AddrRep      ls rs
 293 primCode ls IndexOffForeignObjOp_Float     rs = primCode_IndexOffForeignObjOp FloatRep     ls rs
 294 primCode ls IndexOffForeignObjOp_Double    rs = primCode_IndexOffForeignObjOp DoubleRep    ls rs
 295 primCode ls IndexOffForeignObjOp_StablePtr rs = primCode_IndexOffForeignObjOp StablePtrRep ls rs
 296 primCode ls IndexOffForeignObjOp_Int8      rs = primCode_IndexOffForeignObjOp Int8Rep      ls rs
 297 primCode ls IndexOffForeignObjOp_Int16     rs = primCode_IndexOffForeignObjOp Int16Rep     ls rs
 298 primCode ls IndexOffForeignObjOp_Int32     rs = primCode_IndexOffForeignObjOp Int32Rep     ls rs
 299 primCode ls IndexOffForeignObjOp_Int64     rs = primCode_IndexOffForeignObjOp Int64Rep     ls rs
 300 primCode ls IndexOffForeignObjOp_Word8     rs = primCode_IndexOffForeignObjOp Word8Rep     ls rs
 301 primCode ls IndexOffForeignObjOp_Word16    rs = primCode_IndexOffForeignObjOp Word16Rep    ls rs
 302 primCode ls IndexOffForeignObjOp_Word32    rs = primCode_IndexOffForeignObjOp Word32Rep    ls rs
 303 primCode ls IndexOffForeignObjOp_Word64    rs = primCode_IndexOffForeignObjOp Word64Rep    ls rs
 304
 305 primCode ls ReadOffAddrOp_Char      rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 306 primCode ls ReadOffAddrOp_WideChar  rs = primCode_IndexOffAddrOp CharRep      ls rs
 307 primCode ls ReadOffAddrOp_Int       rs = primCode_IndexOffAddrOp IntRep       ls rs
 308 primCode ls ReadOffAddrOp_Word      rs = primCode_IndexOffAddrOp WordRep      ls rs
 309 primCode ls ReadOffAddrOp_Addr      rs = primCode_IndexOffAddrOp AddrRep      ls rs
 310 primCode ls ReadOffAddrOp_Float     rs = primCode_IndexOffAddrOp FloatRep     ls rs
 311 primCode ls ReadOffAddrOp_Double    rs = primCode_IndexOffAddrOp DoubleRep    ls rs
 312 primCode ls ReadOffAddrOp_StablePtr rs = primCode_IndexOffAddrOp StablePtrRep ls rs
 313 primCode ls ReadOffAddrOp_Int8      rs = primCode_IndexOffAddrOp Int8Rep      ls rs
 314 primCode ls ReadOffAddrOp_Int16     rs = primCode_IndexOffAddrOp Int16Rep     ls rs
 315 primCode ls ReadOffAddrOp_Int32     rs = primCode_IndexOffAddrOp Int32Rep     ls rs
 316 primCode ls ReadOffAddrOp_Int64     rs = primCode_IndexOffAddrOp Int64Rep     ls rs
 317 primCode ls ReadOffAddrOp_Word8     rs = primCode_IndexOffAddrOp Word8Rep     ls rs
 318 primCode ls ReadOffAddrOp_Word16    rs = primCode_IndexOffAddrOp Word16Rep    ls rs
 319 primCode ls ReadOffAddrOp_Word32    rs = primCode_IndexOffAddrOp Word32Rep    ls rs
 320 primCode ls ReadOffAddrOp_Word64    rs = primCode_IndexOffAddrOp Word64Rep    ls rs
 321
 322 primCode ls WriteOffAddrOp_Char      rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 323 primCode ls WriteOffAddrOp_WideChar  rs = primCode_WriteOffAddrOp CharRep      ls rs
 324 primCode ls WriteOffAddrOp_Int       rs = primCode_WriteOffAddrOp IntRep       ls rs
 325 primCode ls WriteOffAddrOp_Word      rs = primCode_WriteOffAddrOp WordRep      ls rs
 326 primCode ls WriteOffAddrOp_Addr      rs = primCode_WriteOffAddrOp AddrRep      ls rs
 327 primCode ls WriteOffAddrOp_Float     rs = primCode_WriteOffAddrOp FloatRep     ls rs
 328 primCode ls WriteOffAddrOp_Double    rs = primCode_WriteOffAddrOp DoubleRep    ls rs
 329 primCode ls WriteOffAddrOp_StablePtr rs = primCode_WriteOffAddrOp StablePtrRep ls rs
 330 primCode ls WriteOffAddrOp_Int8      rs = primCode_WriteOffAddrOp Int8Rep      ls rs
 331 primCode ls WriteOffAddrOp_Int16     rs = primCode_WriteOffAddrOp Int16Rep     ls rs
 332 primCode ls WriteOffAddrOp_Int32     rs = primCode_WriteOffAddrOp Int32Rep     ls rs
 333 primCode ls WriteOffAddrOp_Int64     rs = primCode_WriteOffAddrOp Int64Rep     ls rs
 334 primCode ls WriteOffAddrOp_Word8     rs = primCode_WriteOffAddrOp Word8Rep     ls rs
 335 primCode ls WriteOffAddrOp_Word16    rs = primCode_WriteOffAddrOp Word16Rep    ls rs
 336 primCode ls WriteOffAddrOp_Word32    rs = primCode_WriteOffAddrOp Word32Rep    ls rs
 337 primCode ls WriteOffAddrOp_Word64    rs = primCode_WriteOffAddrOp Word64Rep    ls rs
 338
 339 \end{code}
 340
 341 ToDo: saving/restoring of volatile regs around ccalls.
 342
 343 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
 344 rather than inheriting the calling convention of the thing which we're really
 345 calling.
 346
 347 \begin{code}
 348 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
 349   | is_asm = error "ERROR: Native code generator can't handle casm"
 350   | not may_gc = returnUs (\xs -> ccall : xs)
 351   | otherwise =
 352         save_thread_state       `thenUs` \ save ->
 353         load_thread_state       `thenUs` \ load ->
 354         getUniqueUs             `thenUs` \ uniq ->
 355         let
 356            id  = StReg (StixTemp uniq IntRep)
 357
 358            suspend = StAssign IntRep id
 359                         (StCall SLIT("suspendThread") {-no:cconv-} cCallConv
 360                                 IntRep [stgBaseReg])
 361            resume  = StCall SLIT("resumeThread") {-no:cconv-} cCallConv
 362                             VoidRep [id]
 363         in
 364         returnUs (\xs -> save (suspend : ccall : resume : load xs))
 365
 366   where
 367     args = map amodeCodeForCCall rhs
 368     amodeCodeForCCall x =
 369         let base = amodeToStix' x
 370         in
 371             case getAmodeRep x of
 372               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 373               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 374               ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
 375               _ -> base
 376
 377     ccall = case lhs of
 378       [] -> StCall fn cconv VoidRep args
 379       [lhs] ->
 380           let lhs' = amodeToStix lhs
 381               pk   = case getAmodeRep lhs of
 382                         FloatRep  -> FloatRep
 383                         DoubleRep -> DoubleRep
 384                         other     -> IntRep
 385           in
 386               StAssign pk lhs' (StCall fn cconv pk args)
 387 \end{code}
 388
 389 DataToTagOp won't work for 64-bit archs, as it is.
 390
 391 \begin{code}
 392 primCode [lhs] DataToTagOp [arg]
 393   = let lhs'        = amodeToStix lhs
 394         arg'        = amodeToStix arg
 395         infoptr     = StInd PtrRep arg'
 396         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 397         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 398         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 399 #ifdef WORDS_BIGENDIAN
 400         masked      = masked_be32
 401 #else
 402         masked      = masked_le32
 403 #endif
 404         assign      = StAssign IntRep lhs' masked
 405     in
 406     returnUs (\xs -> assign : xs)
 407 \end{code}
 408
 409 MutVars are pretty simple.
 410 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 411
 412 \begin{code}
 413 primCode [] WriteMutVarOp [aa,vv]
 414    = let aa_s      = amodeToStix aa
 415          vv_s      = amodeToStix vv
 416          var_field = StIndex PtrRep aa_s fixedHS
 417          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 418      in
 419      returnUs (\xs -> assign : xs)
 420
 421 primCode [rr] ReadMutVarOp [aa]
 422    = let aa_s      = amodeToStix aa
 423          rr_s      = amodeToStix rr
 424          var_field = StIndex PtrRep aa_s fixedHS
 425          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 426      in
 427      returnUs (\xs -> assign : xs)
 428 \end{code}
 429
 430 ForeignObj# primops.
 431
 432 \begin{code}
 433 primCode [rr] ForeignObjToAddrOp [fo]
 434   = let code =  StAssign AddrRep (amodeToStix rr)
 435                    (StInd AddrRep
 436                         (StIndex PtrRep (amodeToStix fo) fixedHS))
 437     in
 438     returnUs (\xs -> code : xs)
 439
 440 primCode [] TouchOp [_] = returnUs id
 441 \end{code}
 442
 443 Now the more mundane operations.
 444
 445 \begin{code}
 446 primCode lhs op rhs
 447   = let
 448         lhs' = map amodeToStix  lhs
 449         rhs' = map amodeToStix' rhs
 450         pk   = getAmodeRep (head lhs)
 451     in
 452     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 453 \end{code}
 454
 455 Helper fns for some array ops.
 456
 457 \begin{code}
 458 primCode_ReadByteArrayOp pk [lhs] [obj, ix]
 459   = let
 460         lhs' = amodeToStix lhs
 461         obj' = amodeToStix obj
 462         ix' = amodeToStix ix
 463         base = StIndex IntRep obj' arrWordsHS
 464         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 465     in
 466     returnUs (\xs -> assign : xs)
 467
 468
 469 primCode_IndexOffAddrOp pk [lhs] [obj, ix]
 470   = let
 471         lhs' = amodeToStix lhs
 472         obj' = amodeToStix obj
 473         ix' = amodeToStix ix
 474         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 475     in
 476     returnUs (\xs -> assign : xs)
 477
 478
 479 primCode_IndexOffForeignObjOp pk [lhs] [obj, ix]
 480   = let
 481         lhs' = amodeToStix lhs
 482         obj' = amodeToStix obj
 483         ix' = amodeToStix ix
 484         obj'' = StIndex AddrRep obj' fixedHS
 485         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 486     in
 487     returnUs (\xs -> assign : xs)
 488
 489
 490 primCode_WriteOffAddrOp pk [] [obj, ix, v]
 491   = let
 492         obj' = amodeToStix obj
 493         ix' = amodeToStix ix
 494         v' = amodeToStix v
 495         assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
 496     in
 497     returnUs (\xs -> assign : xs)
 498
 499
 500 primCode_WriteByteArrayOp pk [] [obj, ix, v]
 501   = let
 502         obj' = amodeToStix obj
 503         ix' = amodeToStix ix
 504         v' = amodeToStix v
 505         base = StIndex IntRep obj' arrWordsHS
 506         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 507     in
 508     returnUs (\xs -> assign : xs)
 509
 510 \end{code}
 511
 512 \begin{code}
 513 simpleCoercion
 514       :: PrimRep
 515       -> CAddrMode
 516       -> CAddrMode
 517       -> UniqSM StixTreeList
 518
 519 simpleCoercion pk lhs rhs
 520   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 521
 522
 523 -- Rewrite a narrowing coercion into a pair of shifts.
 524 narrowingCoercion
 525       :: PrimRep   -> PrimRep
 526       -> CAddrMode -> CAddrMode
 527       -> UniqSM StixTreeList
 528
 529 narrowingCoercion pks pkd dst src
 530   | szd > szs
 531   = panic "StixPrim.narrowingCoercion"
 532   | szd == szs
 533   = returnUs (\xs -> StAssign pkd dst' src' : xs)
 534   | otherwise
 535   = returnUs (\xs -> assign : xs)
 536     where
 537           szs       = getPrimRepSizeInBytes pks
 538           szd       = getPrimRepSizeInBytes pkd
 539           src'      = amodeToStix src
 540           dst'      = amodeToStix dst
 541           shift_amt = fromIntegral (8 * (szs - szd))
 542
 543           assign
 544              = StAssign pkd dst'
 545                   (StPrim (if signed then ISraOp else SrlOp)
 546                      [StPrim SllOp [src', StInt shift_amt],
 547                       StInt shift_amt])
 548           signed
 549              = case pkd of
 550                   Int8Rep -> True; Int16Rep -> True
 551                   Int32Rep -> True; Int64Rep -> True; IntRep -> True
 552                   Word8Rep -> False; Word16Rep -> False
 553                   Word32Rep -> False; Word64Rep -> False; WordRep -> False
 554                   other -> pprPanic "StixPrim.narrowingCoercion" (ppr pkd)
 555 \end{code}
 556
 557 Here we try to rewrite primitives into a form the code generator can
 558 understand.  Any primitives not handled here must be handled at the
 559 level of the specific code generator.
 560
 561 \begin{code}
 562 simplePrim
 563     :: PrimRep          -- Rep of first destination
 564     -> [StixTree]       -- Destinations
 565     -> PrimOp
 566     -> [StixTree]
 567     -> StixTree
 568 \end{code}
 569
 570 Now look for something more conventional.
 571
 572 \begin{code}
 573 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 574 simplePrim pk as    op bs    = simplePrim_error op
 575
 576 simplePrim_error op
 577     = error ("ERROR: primitive operation `"++show op++"'cannot be handled\nby the native-code generator.  Workaround: use -fvia-C.\n(Perhaps you should report it as a GHC bug, also.)\n")
 578 \end{code}
 579
 580 %---------------------------------------------------------------------
 581
 582 Here we generate the Stix code for CAddrModes.
 583
 584 When a character is fetched from a mixed type location, we have to do
 585 an extra cast.  This is reflected in amodeCode', which is for rhs
 586 amodes that might possibly need the extra cast.
 587
 588 \begin{code}
 589 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 590
 591 amodeToStix'{-'-} am@(CVal rr CharRep)
 592     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 593     | otherwise = amodeToStix am
 594
 595 amodeToStix' am = amodeToStix am
 596
 597 -----------
 598 amodeToStix am@(CVal rr CharRep)
 599   | mixedTypeLocn am
 600   = StInd IntRep (amodeToStix (CAddr rr))
 601
 602 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 603
 604 amodeToStix (CAddr (SpRel off))
 605   = StIndex PtrRep stgSp (StInt (toInteger (iBox off)))
 606
 607 amodeToStix (CAddr (HpRel off))
 608   = StIndex IntRep stgHp (StInt (toInteger (- (iBox off))))
 609
 610 amodeToStix (CAddr (NodeRel off))
 611   = StIndex IntRep stgNode (StInt (toInteger (iBox off)))
 612
 613 amodeToStix (CAddr (CIndex base off pk))
 614   = StIndex pk (amodeToStix base) (amodeToStix off)
 615
 616 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 617 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 618
 619 amodeToStix (CLbl      lbl _) = StCLbl lbl
 620
 621  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 622
 623 amodeToStix (CCharLike (CLit (MachChar c)))
 624   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 625   where
 626     off = charLikeSize * (c - mIN_CHARLIKE)
 627
 628 amodeToStix (CCharLike x)
 629   = panic "CCharLike"
 630
 631 amodeToStix (CIntLike (CLit (MachInt i)))
 632   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 633   where
 634     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 635
 636 amodeToStix (CIntLike x)
 637   = panic "CIntLike"
 638
 639 amodeToStix (CLit core)
 640   = case core of
 641       MachChar c     -> StInt (toInteger c)
 642       MachStr s      -> StString s
 643       MachAddr a     -> StInt a
 644       MachInt i      -> StInt i
 645       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 646       MachLitLit s _ -> litLitErr
 647       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 648       MachFloat d    -> StFloat d
 649       MachDouble d   -> StDouble d
 650       _ -> panic "amodeToStix:core literal"
 651
 652 amodeToStix (CMacroExpr _ macro [arg])
 653   = case macro of
 654       ENTRY_CODE -> amodeToStix arg
 655       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 656       GET_TAG    ->
 657 #ifdef WORDS_BIGENDIAN
 658                     StPrim AndOp
 659                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 660                                                 (StInt (toInteger (-1)))),
 661                          StInt 65535]
 662 #else
 663                     StPrim SrlOp
 664                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 665                                                 (StInt (toInteger (-1)))),
 666                          StInt 16]
 667 #endif
 668       UPD_FRAME_UPDATEE
 669          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 670                                          (StInt (toInteger uF_UPDATEE)))
 671
 672 litLitErr =
 673   panic "native code generator can't compile lit-lits, use -fvia-C"
 674 \end{code}
 675
 676 Sizes of the CharLike and IntLike closures that are arranged as arrays
 677 in the data segment.  (These are in bytes.)
 678
 679 \begin{code}
 680 -- The INTLIKE base pointer
 681
 682 iNTLIKE_closure :: StixTree
 683 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 684
 685 -- The CHARLIKE base
 686
 687 cHARLIKE_closure :: StixTree
 688 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 689
 690 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 691
 692 -- these are the sizes of charLike and intLike closures, in _bytes_.
 693 charLikeSize = (fixedHdrSize + 1) * (sizeOf PtrRep)
 694 intLikeSize  = (fixedHdrSize + 1) * (sizeOf PtrRep)
 695 \end{code}
 696
 697
 698 \begin{code}
 699 save_thread_state
 700    = getUniqueUs   `thenUs` \tso_uq ->
 701      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 702      returnUs (\xs ->
 703         StAssign ThreadIdRep tso stgCurrentTSO :
 704         StAssign PtrRep
 705            (StInd PtrRep (StPrim IntAddOp
 706                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 707            stgSp :
 708         StAssign PtrRep
 709            (StInd PtrRep (StPrim IntAddOp
 710                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 711            stgSu :
 712         StAssign PtrRep
 713            (StInd PtrRep (StPrim IntAddOp
 714                 [stgCurrentNursery,
 715                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
 716            (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
 717         xs
 718      )
 719
 720 load_thread_state
 721    = getUniqueUs   `thenUs` \tso_uq ->
 722      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 723      returnUs (\xs ->
 724         StAssign ThreadIdRep tso stgCurrentTSO :
 725         StAssign PtrRep stgSp
 726            (StInd PtrRep (StPrim IntAddOp
 727                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
 728         StAssign PtrRep stgSu
 729            (StInd PtrRep (StPrim IntAddOp
 730                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
 731         StAssign PtrRep stgSpLim
 732            (StPrim IntAddOp [tso,
 733                              StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 734                                                *BYTES_PER_WORD))]) :
 735         StAssign PtrRep stgHp
 736            (StPrim IntSubOp [
 737               StInd PtrRep (StPrim IntAddOp
 738                 [stgCurrentNursery,
 739                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 740               StInt (toInteger (1 * BYTES_PER_WORD))
 741             ]) :
 742         StAssign PtrRep stgHpLim
 743            (StPrim IntAddOp [
 744               StInd PtrRep (StPrim IntAddOp
 745                 [stgCurrentNursery,
 746                  StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
 747               StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
 748             ]) :
 749         xs
 750      )
 751 \end{code}