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 = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 274           in
 275               StAssign pk lhs' (StCall fn cconv pk args)
 276 \end{code}
 277
 278 DataToTagOp won't work for 64-bit archs, as it is.
 279
 280 \begin{code}
 281 primCode [lhs] DataToTagOp [arg]
 282   = let lhs'        = amodeToStix lhs
 283         arg'        = amodeToStix arg
 284         infoptr     = StInd PtrRep arg'
 285         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 286         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 287         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 288 #ifdef WORDS_BIGENDIAN
 289         masked      = masked_be32
 290 #else
 291         masked      = masked_le32
 292 #endif
 293         assign      = StAssign IntRep lhs' masked
 294     in
 295     returnUs (\xs -> assign : xs)
 296 \end{code}
 297
 298 MutVars are pretty simple.
 299 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 300
 301 \begin{code}
 302 primCode [] WriteMutVarOp [aa,vv]
 303    = let aa_s      = amodeToStix aa
 304          vv_s      = amodeToStix vv
 305          var_field = StIndex PtrRep aa_s fixedHS
 306          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 307      in
 308      returnUs (\xs -> assign : xs)
 309
 310 primCode [rr] ReadMutVarOp [aa]
 311    = let aa_s      = amodeToStix aa
 312          rr_s      = amodeToStix rr
 313          var_field = StIndex PtrRep aa_s fixedHS
 314          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 315      in
 316      returnUs (\xs -> assign : xs)
 317 \end{code}
 318
 319 Now the more mundane operations.
 320
 321 \begin{code}
 322 primCode lhs op rhs
 323   = let
 324         lhs' = map amodeToStix  lhs
 325         rhs' = map amodeToStix' rhs
 326         pk   = getAmodeRep (head lhs)
 327     in
 328     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 329 \end{code}
 330
 331 \begin{code}
 332 simpleCoercion
 333       :: PrimRep
 334       -> CAddrMode
 335       -> CAddrMode
 336       -> UniqSM StixTreeList
 337
 338 simpleCoercion pk lhs rhs
 339   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 340 \end{code}
 341
 342 Here we try to rewrite primitives into a form the code generator can
 343 understand.  Any primitives not handled here must be handled at the
 344 level of the specific code generator.
 345
 346 \begin{code}
 347 simplePrim
 348     :: PrimRep          -- Rep of first destination
 349     -> [StixTree]       -- Destinations
 350     -> PrimOp
 351     -> [StixTree]
 352     -> StixTree
 353 \end{code}
 354
 355 Now look for something more conventional.
 356
 357 \begin{code}
 358 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 359 simplePrim pk as    op bs    = simplePrim_error op
 360
 361 simplePrim_error op
 362     = 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")
 363 \end{code}
 364
 365 %---------------------------------------------------------------------
 366
 367 Here we generate the Stix code for CAddrModes.
 368
 369 When a character is fetched from a mixed type location, we have to do
 370 an extra cast.  This is reflected in amodeCode', which is for rhs
 371 amodes that might possibly need the extra cast.
 372
 373 \begin{code}
 374 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 375
 376 amodeToStix'{-'-} am@(CVal rr CharRep)
 377     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 378     | otherwise = amodeToStix am
 379
 380 amodeToStix' am = amodeToStix am
 381
 382 -----------
 383 amodeToStix am@(CVal rr CharRep)
 384   | mixedTypeLocn am
 385   = StInd IntRep (amodeToStix (CAddr rr))
 386
 387 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 388
 389 amodeToStix (CAddr (SpRel off))
 390   = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
 391
 392 amodeToStix (CAddr (HpRel off))
 393   = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
 394
 395 amodeToStix (CAddr (NodeRel off))
 396   = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
 397
 398 amodeToStix (CAddr (CIndex base off pk))
 399   = StIndex pk (amodeToStix base) (amodeToStix off)
 400
 401 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 402 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 403
 404 amodeToStix (CLbl      lbl _) = StCLbl lbl
 405
 406  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 407
 408 amodeToStix (CCharLike (CLit (MachChar c)))
 409   = StIndex CharRep cHARLIKE_closure (StInt (toInteger off))
 410   where
 411     off = charLikeSize * ord c
 412
 413 amodeToStix (CCharLike x)
 414   = StIndex CharRep cHARLIKE_closure off
 415   where
 416     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 417
 418 amodeToStix (CIntLike (CLit (MachInt i)))
 419   = StIndex CharRep{-yes,really-} iNTLIKE_closure (StInt (toInteger off))
 420   where
 421     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 422
 423 amodeToStix (CIntLike x)
 424   = panic "CIntLike"
 425
 426 amodeToStix (CLit core)
 427   = case core of
 428       MachChar c     -> StInt (toInteger (ord c))
 429       MachStr s      -> StString s
 430       MachAddr a     -> StInt a
 431       MachInt i      -> StInt i
 432       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 433       MachLitLit s _ -> litLitErr
 434       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 435       MachFloat d    -> StDouble d
 436       MachDouble d   -> StDouble d
 437       _ -> panic "amodeToStix:core literal"
 438
 439 amodeToStix (CMacroExpr _ macro [arg])
 440   = case macro of
 441       ENTRY_CODE -> amodeToStix arg
 442       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 443       GET_TAG    ->
 444 #ifdef WORDS_BIGENDIAN
 445                     StPrim AndOp
 446                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 447                                                 (StInt (toInteger (-1)))),
 448                          StInt 65535]
 449 #else
 450                     StPrim SrlOp
 451                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 452                                                 (StInt (toInteger (-1)))),
 453                          StInt 16]
 454 #endif
 455       UPD_FRAME_UPDATEE
 456          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 457                                          (StInt (toInteger uF_UPDATEE)))
 458
 459 litLitErr =
 460   panic "native code generator can't compile lit-lits, use -fvia-C"
 461 \end{code}
 462
 463 Sizes of the CharLike and IntLike closures that are arranged as arrays
 464 in the data segment.  (These are in bytes.)
 465
 466 \begin{code}
 467 -- The INTLIKE base pointer
 468
 469 iNTLIKE_closure :: StixTree
 470 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 471
 472 -- The CHARLIKE base
 473
 474 cHARLIKE_closure :: StixTree
 475 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 476
 477 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 478
 479 -- these are the sizes of charLike and intLike closures, in _bytes_.
 480 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 481 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 482 \end{code}
 483
 484
 485 \begin{code}
 486 save_thread_state
 487    = getUniqueUs   `thenUs` \tso_uq ->
 488      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 489      returnUs (\xs ->
 490         StAssign ThreadIdRep tso stgCurrentTSO :
 491         StAssign PtrRep
 492            (StInd PtrRep (StPrim IntAddOp
 493                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 494            stgSp :
 495         StAssign PtrRep
 496            (StInd PtrRep (StPrim IntAddOp
 497                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 498            stgSu :
 499         StAssign PtrRep
 500            (StInd PtrRep (StPrim IntAddOp
 501                 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))]))
 502            stgSpLim :
 503         StAssign PtrRep
 504            (StInd PtrRep (StPrim IntAddOp
 505                 [stgCurrentNursery,
 506                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]))
 507            (StPrim IntAddOp [stgHp, StInt (toInteger (1 * BYTES_PER_WORD))]) :
 508         xs
 509      )
 510
 511 load_thread_state
 512    = getUniqueUs   `thenUs` \tso_uq ->
 513      let tso = StReg (StixTemp tso_uq ThreadIdRep) in
 514      returnUs (\xs ->
 515         StAssign ThreadIdRep tso stgCurrentTSO :
 516         StAssign PtrRep stgSp
 517            (StInd PtrRep (StPrim IntAddOp
 518                 [tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])) :
 519         StAssign PtrRep stgSu
 520            (StInd PtrRep (StPrim IntAddOp
 521                 [tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])) :
 522         StAssign PtrRep stgSpLim
 523            (StInd PtrRep (StPrim IntAddOp
 524                 [tso, StInt (toInteger (TSO_SPLIM*BYTES_PER_WORD))])) :
 525         StAssign PtrRep stgHp
 526            (StPrim IntSubOp [
 527               StInd PtrRep (StPrim IntAddOp
 528                 [stgCurrentNursery,
 529                  StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 530               StInt (toInteger (1 * BYTES_PER_WORD))
 531             ]) :
 532         StAssign PtrRep stgHpLim
 533            (StPrim IntAddOp [
 534               StInd PtrRep (StPrim IntAddOp
 535                 [stgCurrentNursery,
 536                  StInt (toInteger (BDESCR_START * BYTES_PER_WORD))]),
 537               StInt (toInteger (bLOCK_SIZE - (1 * BYTES_PER_WORD)))
 538             ]) :
 539         xs
 540      )
 541 \end{code}