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(..), isFloatingRep )
  20 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  21 import Constants        ( mIN_INTLIKE, uF_UPDATEE, bLOCK_SIZE )
  22 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  23                           mkMAP_FROZEN_infoLabel, mkForeignLabel )
  24 import Outputable
  25
  26 import Char             ( ord, isAlpha, isDigit )
  27
  28 #include "NCG.h"
  29 \end{code}
  30
  31 The main honcho here is primCode, which handles the guts of COpStmts.
  32
  33 \begin{code}
  34 primCode
  35     :: [CAddrMode]      -- results
  36     -> PrimOp           -- op
  37     -> [CAddrMode]      -- args
  38     -> UniqSM StixTreeList
  39 \end{code}
  40
  41 First, the dreaded @ccall@.  We can't handle @casm@s.
  42
  43 Usually, this compiles to an assignment, but when the left-hand side
  44 is empty, we just perform the call and ignore the result.
  45
  46 btw Why not let programmer use casm to provide assembly code instead
  47 of C code?  ADR
  48
  49 The (MP) integer operations are a true nightmare.  Since we don't have
  50 a convenient abstract way of allocating temporary variables on the (C)
  51 stack, we use the space just below HpLim for the @MP_INT@ structures,
  52 and modify our heap check accordingly.
  53
  54 \begin{code}
  55 -- NB: ordering of clauses somewhere driven by
  56 -- the desire to getting sane patt-matching behavior
  57 primCode res@[sr,dr] IntegerNegOp arg@[sa,da]
  58   = gmpNegate (sr,dr) (sa,da)
  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 \end{code}
  84
  85 \begin{code}
  86 primCode [res] SameMutableArrayOp args
  87   = let
  88         compare = StPrim AddrEqOp (map amodeToStix args)
  89         assign = StAssign IntRep (amodeToStix res) compare
  90     in
  91     returnUs (\xs -> assign : xs)
  92
  93 primCode res@[_] SameMutableByteArrayOp args
  94   = primCode res SameMutableArrayOp args
  95
  96 primCode res@[_] SameMutVarOp args
  97   = primCode res SameMutableArrayOp args
  98
  99 primCode res@[_] SameMVarOp args
 100   = primCode res SameMutableArrayOp args
 101 \end{code}
 102
 103 Freezing an array of pointers is a double assignment.  We fix the
 104 header of the ``new'' closure because the lhs is probably a better
 105 addressing mode for the indirection (most likely, it's a VanillaReg).
 106
 107 \begin{code}
 108
 109 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 110   = let
 111         lhs' = amodeToStix lhs
 112         rhs' = amodeToStix rhs
 113         header = StInd PtrRep lhs'
 114         assign = StAssign PtrRep lhs' rhs'
 115         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 116     in
 117     returnUs (\xs -> assign : freeze : xs)
 118
 119 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 120   = simpleCoercion PtrRep lhs rhs
 121 \end{code}
 122
 123 Returning the size of (mutable) byte arrays is just
 124 an indexing operation.
 125
 126 \begin{code}
 127 primCode [lhs] SizeofByteArrayOp [rhs]
 128   = let
 129         lhs' = amodeToStix lhs
 130         rhs' = amodeToStix rhs
 131         sz   = StIndex IntRep rhs' fixedHS
 132         assign = StAssign IntRep lhs' (StInd IntRep sz)
 133     in
 134     returnUs (\xs -> assign : xs)
 135
 136 primCode [lhs] SizeofMutableByteArrayOp [rhs]
 137   = let
 138         lhs' = amodeToStix lhs
 139         rhs' = amodeToStix rhs
 140         sz   = StIndex IntRep rhs' fixedHS
 141         assign = StAssign IntRep lhs' (StInd IntRep sz)
 142     in
 143     returnUs (\xs -> assign : xs)
 144
 145 \end{code}
 146
 147 Most other array primitives translate to simple indexing.
 148
 149 \begin{code}
 150 primCode lhs@[_] IndexArrayOp args
 151   = primCode lhs ReadArrayOp args
 152
 153 primCode [lhs] ReadArrayOp [obj, ix]
 154   = let
 155         lhs' = amodeToStix lhs
 156         obj' = amodeToStix obj
 157         ix' = amodeToStix ix
 158         base = StIndex IntRep obj' arrPtrsHS
 159         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 160     in
 161     returnUs (\xs -> assign : xs)
 162
 163 primCode [] WriteArrayOp [obj, ix, v]
 164   = let
 165         obj' = amodeToStix obj
 166         ix' = amodeToStix ix
 167         v' = amodeToStix v
 168         base = StIndex IntRep obj' arrPtrsHS
 169         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 170     in
 171     returnUs (\xs -> assign : xs)
 172
 173 primCode lhs@[_] (IndexByteArrayOp pk) args
 174   = primCode lhs (ReadByteArrayOp pk) args
 175
 176 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 177
 178 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 179   = let
 180         lhs' = amodeToStix lhs
 181         obj' = amodeToStix obj
 182         ix' = amodeToStix ix
 183         base = StIndex IntRep obj' arrWordsHS
 184         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 185     in
 186     returnUs (\xs -> assign : xs)
 187
 188 primCode lhs@[_] (ReadOffAddrOp pk) args
 189   = primCode lhs (IndexOffAddrOp pk) args
 190
 191 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 192   = let
 193         lhs' = amodeToStix lhs
 194         obj' = amodeToStix obj
 195         ix' = amodeToStix ix
 196         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 197     in
 198     returnUs (\xs -> assign : xs)
 199
 200 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 201   = let
 202         lhs' = amodeToStix lhs
 203         obj' = amodeToStix obj
 204         ix' = amodeToStix ix
 205         obj'' = StIndex AddrRep obj' fixedHS
 206         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 207     in
 208     returnUs (\xs -> assign : xs)
 209
 210 primCode [] (WriteOffAddrOp pk) [obj, ix, v]
 211   = let
 212         obj' = amodeToStix obj
 213         ix' = amodeToStix ix
 214         v' = amodeToStix v
 215         assign = StAssign pk (StInd pk (StIndex pk obj' ix')) v'
 216     in
 217     returnUs (\xs -> assign : xs)
 218
 219 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 220   = let
 221         obj' = amodeToStix obj
 222         ix' = amodeToStix ix
 223         v' = amodeToStix v
 224         base = StIndex IntRep obj' arrWordsHS
 225         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 226     in
 227     returnUs (\xs -> assign : xs)
 228
 229 primCode [] WriteForeignObjOp [obj, v]
 230   = let
 231         obj' = amodeToStix obj
 232         v' = amodeToStix v
 233         obj'' = StIndex AddrRep obj' (StInt 4711) -- fixedHS
 234         assign = StAssign AddrRep (StInd AddrRep obj'') v'
 235     in
 236     returnUs (\xs -> assign : xs)
 237 \end{code}
 238
 239 ToDo: saving/restoring of volatile regs around ccalls.
 240
 241 \begin{code}
 242 primCode lhs (CCallOp (CCall (StaticTarget fn) is_asm may_gc cconv)) rhs
 243   | is_asm = error "ERROR: Native code generator can't handle casm"
 244   | not may_gc = returnUs (\xs -> ccall : xs)
 245   | otherwise =
 246         save_thread_state       `thenUs` \ save ->
 247         load_thread_state       `thenUs` \ load ->
 248         getUniqueUs             `thenUs` \ uniq ->
 249         let
 250            id  = StReg (StixTemp uniq IntRep)
 251
 252            suspend = StAssign IntRep id
 253                         (StCall SLIT("suspendThread") cconv IntRep [stgBaseReg])
 254            resume  = StCall SLIT("resumeThread") cconv VoidRep [id]
 255         in
 256         returnUs (\xs -> save (suspend : ccall : resume : load xs))
 257
 258   where
 259     args = map amodeCodeForCCall rhs
 260     amodeCodeForCCall x =
 261         let base = amodeToStix' x
 262         in
 263             case getAmodeRep x of
 264               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 265               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 266               ForeignObjRep -> StIndex PtrRep base fixedHS
 267               _ -> base
 268
 269     ccall = case lhs of
 270       [] -> StCall fn cconv VoidRep args
 271       [lhs] ->
 272           let lhs' = amodeToStix lhs
 273               pk   = case getAmodeRep lhs of
 274                         FloatRep  -> FloatRep
 275                         DoubleRep -> DoubleRep
 276                         other     -> IntRep
 277           in
 278               StAssign pk lhs' (StCall fn cconv pk args)
 279 \end{code}
 280
 281 DataToTagOp won't work for 64-bit archs, as it is.
 282
 283 \begin{code}
 284 primCode [lhs] DataToTagOp [arg]
 285   = let lhs'        = amodeToStix lhs
 286         arg'        = amodeToStix arg
 287         infoptr     = StInd PtrRep arg'
 288         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 289         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 290         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 291 #ifdef WORDS_BIGENDIAN
 292         masked      = masked_be32
 293 #else
 294         masked      = masked_le32
 295 #endif
 296         assign      = StAssign IntRep lhs' masked
 297     in
 298     returnUs (\xs -> assign : xs)
 299 \end{code}
 300
 301 MutVars are pretty simple.
 302 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 303
 304 \begin{code}
 305 primCode [] WriteMutVarOp [aa,vv]
 306    = let aa_s      = amodeToStix aa
 307          vv_s      = amodeToStix vv
 308          var_field = StIndex PtrRep aa_s fixedHS
 309          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 310      in
 311      returnUs (\xs -> assign : xs)
 312
 313 primCode [rr] ReadMutVarOp [aa]
 314    = let aa_s      = amodeToStix aa
 315          rr_s      = amodeToStix rr
 316          var_field = StIndex PtrRep aa_s fixedHS
 317          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 318      in
 319      returnUs (\xs -> assign : xs)
 320 \end{code}
 321
 322 Now the more mundane operations.
 323
 324 \begin{code}
 325 primCode lhs op rhs
 326   = let
 327         lhs' = map amodeToStix  lhs
 328         rhs' = map amodeToStix' rhs
 329         pk   = getAmodeRep (head lhs)
 330     in
 331     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 332 \end{code}
 333
 334 \begin{code}
 335 simpleCoercion
 336       :: PrimRep
 337       -> CAddrMode
 338       -> CAddrMode
 339       -> UniqSM StixTreeList
 340
 341 simpleCoercion pk lhs rhs
 342   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 343 \end{code}
 344
 345 Here we try to rewrite primitives into a form the code generator can
 346 understand.  Any primitives not handled here must be handled at the
 347 level of the specific code generator.
 348
 349 \begin{code}
 350 simplePrim
 351     :: PrimRep          -- Rep of first destination
 352     -> [StixTree]       -- Destinations
 353     -> PrimOp
 354     -> [StixTree]
 355     -> StixTree
 356 \end{code}
 357
 358 Now look for something more conventional.
 359
 360 \begin{code}
 361 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 362 simplePrim pk as    op bs    = simplePrim_error op
 363
 364 simplePrim_error op
 365     = 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")
 366 \end{code}
 367
 368 %---------------------------------------------------------------------
 369
 370 Here we generate the Stix code for CAddrModes.
 371
 372 When a character is fetched from a mixed type location, we have to do
 373 an extra cast.  This is reflected in amodeCode', which is for rhs
 374 amodes that might possibly need the extra cast.
 375
 376 \begin{code}
 377 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 378
 379 amodeToStix'{-'-} am@(CVal rr CharRep)
 380     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 381     | otherwise = amodeToStix am
 382
 383 amodeToStix' am = amodeToStix am
 384
 385 -----------
 386 amodeToStix am@(CVal rr CharRep)
 387   | mixedTypeLocn am
 388   = StInd IntRep (amodeToStix (CAddr rr))
 389
 390 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 391
 392 amodeToStix (CAddr (SpRel off))
 393   = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
 394
 395 amodeToStix (CAddr (HpRel off))
 396   = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
 397
 398 amodeToStix (CAddr (NodeRel off))
 399   = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
 400
 401 amodeToStix (CAddr (CIndex base off pk))
 402   = StIndex pk (amodeToStix base) (amodeToStix off)
 403
 404 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 405 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 406
 407 amodeToStix (CLbl      lbl _) = StCLbl lbl
 408
 409  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 410
 411 amodeToStix (CCharLike (CLit (MachChar c)))
 412   = StIndex CharRep cHARLIKE_closure (StInt (toInteger off))
 413   where
 414     off = charLikeSize * ord c
 415
 416 amodeToStix (CCharLike x)
 417   = StIndex CharRep cHARLIKE_closure off
 418   where
 419     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 420
 421 amodeToStix (CIntLike (CLit (MachInt i)))
 422   = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off))
 423   where
 424     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 425
 426 amodeToStix (CIntLike x)
 427   = panic "CIntLike"
 428
 429 amodeToStix (CLit core)
 430   = case core of
 431       MachChar c     -> StInt (toInteger (ord c))
 432       MachStr s      -> StString s
 433       MachAddr a     -> StInt a
 434       MachInt i      -> StInt i
 435       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 436       MachLitLit s _ -> litLitErr
 437       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 438       MachFloat d    -> StFloat d
 439       MachDouble d   -> StDouble d
 440       _ -> panic "amodeToStix:core literal"
 441
 442 amodeToStix (CMacroExpr _ macro [arg])
 443   = case macro of
 444       ENTRY_CODE -> amodeToStix arg
 445       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 446       GET_TAG    ->
 447 #ifdef WORDS_BIGENDIAN
 448                     StPrim AndOp
 449                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 450                                                 (StInt (toInteger (-1)))),
 451                          StInt 65535]
 452 #else
 453                     StPrim SrlOp
 454                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 455                                                 (StInt (toInteger (-1)))),
 456                          StInt 16]
 457 #endif
 458       UPD_FRAME_UPDATEE
 459          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 460                                          (StInt (toInteger uF_UPDATEE)))
 461
 462 litLitErr =
 463   panic "native code generator can't compile lit-lits, use -fvia-C"
 464 \end{code}
 465
 466 Sizes of the CharLike and IntLike closures that are arranged as arrays
 467 in the data segment.  (These are in bytes.)
 468
 469 \begin{code}
 470 -- The INTLIKE base pointer
 471
 472 iNTLIKE_closure :: StixTree
 473 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 474
 475 -- The CHARLIKE base
 476
 477 cHARLIKE_closure :: StixTree
 478 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 479
 480 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 481
 482 -- these are the sizes of charLike and intLike closures, in _bytes_.
 483 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 484 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 485 \end{code}
 486
 487
 488 \begin{code}
 489 save_thread_state
 490    = getUniqueUs   `thenUs` \tso_uq ->
 491      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 492      returnUs (\xs ->
 493         StAssign ThreadIdRep tso stgCurrentTSO :
 494         StAssign PtrRep
 495            (StInd PtrRep (StPrim IntAddOp
 496                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 497            stgSp :
 498         StAssign PtrRep
 499            (StInd PtrRep (StPrim IntAddOp
 500                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 501            stgSu :
 502         StAssign PtrRep
 503            (StInd PtrRep (StPrim IntAddOp
 504                 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
 505            stgSpLim :
 506         StAssign PtrRep
 507            (StInd PtrRep (StPrim IntAddOp
 508                 [stgCurrentNursery,
 509                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
 510            (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
 511         xs
 512      )
 513
 514 load_thread_state
 515    = getUniqueUs   `thenUs` \tso_uq ->
 516      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 517      returnUs (\xs ->
 518         StAssign ThreadIdRep tso stgCurrentTSO :
 519         StAssign PtrRep stgSp
 520            (StInd PtrRep (StPrim IntAddOp
 521                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
 522         StAssign PtrRep stgSu
 523            (StInd PtrRep (StPrim IntAddOp
 524                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
 525         StAssign PtrRep stgSpLim
 526            (StInd PtrRep (StPrim IntAddOp
 527                 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
 528         StAssign PtrRep stgHp
 529            (StPrim IntSubOp [
 530               StInd PtrRep (StPrim IntAddOp
 531                 [stgCurrentNursery,
 532                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 533               StInt (toInteger (1 * BYTES_PER_WORD))
 534             ]) :
 535         StAssign PtrRep stgHpLim
 536            (StPrim IntAddOp [
 537               StInd PtrRep (StPrim IntAddOp
 538                 [stgCurrentNursery,
 539                  StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
 540               StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
 541             ]) :
 542         xs
 543      )
 544 \end{code}