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