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