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