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 Const            ( Literal(..) )
  20 import CallConv         ( cCallConv )
  21 import PrimOp           ( PrimOp(..) )
  22 import PrimRep          ( PrimRep(..), isFloatingRep )
  23 import UniqSupply       ( returnUs, thenUs, 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 \end{code}
  95
  96 Freezing an array of pointers is a double assignment.  We fix the
  97 header of the ``new'' closure because the lhs is probably a better
  98 addressing mode for the indirection (most likely, it's a VanillaReg).
  99
 100 \begin{code}
 101
 102 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 103   = let
 104         lhs' = amodeToStix lhs
 105         rhs' = amodeToStix rhs
 106         header = StInd PtrRep lhs'
 107         assign = StAssign PtrRep lhs' rhs'
 108         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 109     in
 110     returnUs (\xs -> assign : freeze : xs)
 111
 112 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 113   = simpleCoercion PtrRep lhs rhs
 114 \end{code}
 115
 116 Returning the size of (mutable) byte arrays is just
 117 an indexing operation.
 118
 119 \begin{code}
 120 primCode [lhs] SizeofByteArrayOp [rhs]
 121   = let
 122         lhs' = amodeToStix lhs
 123         rhs' = amodeToStix rhs
 124         sz   = StIndex IntRep rhs' fixedHS
 125         assign = StAssign IntRep lhs' (StInd IntRep sz)
 126     in
 127     returnUs (\xs -> assign : xs)
 128
 129 primCode [lhs] SizeofMutableByteArrayOp [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 \end{code}
 139
 140 Most other array primitives translate to simple indexing.
 141
 142 \begin{code}
 143 primCode lhs@[_] IndexArrayOp args
 144   = primCode lhs ReadArrayOp args
 145
 146 primCode [lhs] ReadArrayOp [obj, ix]
 147   = let
 148         lhs' = amodeToStix lhs
 149         obj' = amodeToStix obj
 150         ix' = amodeToStix ix
 151         base = StIndex IntRep obj' arrPtrsHS
 152         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 153     in
 154     returnUs (\xs -> assign : xs)
 155
 156 primCode [] WriteArrayOp [obj, ix, v]
 157   = let
 158         obj' = amodeToStix obj
 159         ix' = amodeToStix ix
 160         v' = amodeToStix v
 161         base = StIndex IntRep obj' arrPtrsHS
 162         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 163     in
 164     returnUs (\xs -> assign : xs)
 165
 166 primCode lhs@[_] (IndexByteArrayOp pk) args
 167   = primCode lhs (ReadByteArrayOp pk) args
 168
 169 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 170
 171 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 172   = let
 173         lhs' = amodeToStix lhs
 174         obj' = amodeToStix obj
 175         ix' = amodeToStix ix
 176         base = StIndex IntRep obj' arrWordsHS
 177         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 178     in
 179     returnUs (\xs -> assign : xs)
 180
 181 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 182   = let
 183         lhs' = amodeToStix lhs
 184         obj' = amodeToStix obj
 185         ix' = amodeToStix ix
 186         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 187     in
 188     returnUs (\xs -> assign : xs)
 189
 190 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 191   = let
 192         lhs' = amodeToStix lhs
 193         obj' = amodeToStix obj
 194         ix' = amodeToStix ix
 195         obj'' = StIndex PtrRep obj' fixedHS
 196         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 197     in
 198     returnUs (\xs -> assign : xs)
 199
 200 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 201   = let
 202         obj' = amodeToStix obj
 203         ix' = amodeToStix ix
 204         v' = amodeToStix v
 205         base = StIndex IntRep obj' arrWordsHS
 206         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 207     in
 208     returnUs (\xs -> assign : xs)
 209 \end{code}
 210
 211 \begin{code}
 212 --primCode lhs (CCallOp fn is_asm may_gc) rhs
 213 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
 214   | is_asm = error "ERROR: Native code generator can't handle casm"
 215   | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
 216   | otherwise
 217   = case lhs of
 218       [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
 219       [lhs] ->
 220           let lhs' = amodeToStix lhs
 221               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 222               call = StAssign pk lhs' (StCall fn cconv pk args)
 223           in
 224               returnUs (\xs -> call : xs)
 225   where
 226     args = map amodeCodeForCCall rhs
 227     amodeCodeForCCall x =
 228         let base = amodeToStix' x
 229         in
 230             case getAmodeRep x of
 231               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 232               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 233               ForeignObjRep -> StIndex PtrRep base fixedHS
 234               _ -> base
 235 \end{code}
 236
 237 DataToTagOp won't work for 64-bit archs, as it is.
 238
 239 \begin{code}
 240 primCode [lhs] DataToTagOp [arg]
 241   = let lhs'        = amodeToStix lhs
 242         arg'        = amodeToStix arg
 243         infoptr     = StInd PtrRep arg'
 244         word_32     = StInd WordRep (StIndex PtrRep infoptr (StInt (-1)))
 245         masked_le32 = StPrim SrlOp [word_32, StInt 16]
 246         masked_be32 = StPrim AndOp [word_32, StInt 65535]
 247 #ifdef WORDS_BIGENDIAN
 248         masked      = masked_be32
 249 #else
 250         masked      = masked_le32
 251 #endif
 252         assign      = StAssign IntRep lhs' masked
 253     in
 254     returnUs (\xs -> assign : xs)
 255 \end{code}
 256
 257 MutVars are pretty simple.
 258 #define writeMutVarzh(a,v)       (P_)(((StgMutVar *)(a))->var)=(v)
 259
 260 \begin{code}
 261 primCode [] WriteMutVarOp [aa,vv]
 262    = let aa_s      = amodeToStix aa
 263          vv_s      = amodeToStix vv
 264          var_field = StIndex PtrRep aa_s fixedHS
 265          assign    = StAssign PtrRep (StInd PtrRep var_field) vv_s
 266      in
 267      returnUs (\xs -> assign : xs)
 268
 269 primCode [rr] ReadMutVarOp [aa]
 270    = let aa_s      = amodeToStix aa
 271          rr_s      = amodeToStix rr
 272          var_field = StIndex PtrRep aa_s fixedHS
 273          assign    = StAssign PtrRep rr_s (StInd PtrRep var_field)
 274      in
 275      returnUs (\xs -> assign : xs)
 276 \end{code}
 277
 278 Now the more mundane operations.
 279
 280 \begin{code}
 281 primCode lhs op rhs
 282   = let
 283         lhs' = map amodeToStix  lhs
 284         rhs' = map amodeToStix' rhs
 285         pk   = getAmodeRep (head lhs)
 286     in
 287     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 288 \end{code}
 289
 290 \begin{code}
 291 simpleCoercion
 292       :: PrimRep
 293       -> CAddrMode
 294       -> CAddrMode
 295       -> UniqSM StixTreeList
 296
 297 simpleCoercion pk lhs rhs
 298   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 299 \end{code}
 300
 301 Here we try to rewrite primitives into a form the code generator can
 302 understand.  Any primitives not handled here must be handled at the
 303 level of the specific code generator.
 304
 305 \begin{code}
 306 simplePrim
 307     :: PrimRep          -- Rep of first destination
 308     -> [StixTree]       -- Destinations
 309     -> PrimOp
 310     -> [StixTree]
 311     -> StixTree
 312 \end{code}
 313
 314 Now look for something more conventional.
 315
 316 \begin{code}
 317 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 318 simplePrim pk as    op bs    = simplePrim_error op
 319
 320 simplePrim_error op
 321     = 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")
 322 \end{code}
 323
 324 %---------------------------------------------------------------------
 325
 326 Here we generate the Stix code for CAddrModes.
 327
 328 When a character is fetched from a mixed type location, we have to do
 329 an extra cast.  This is reflected in amodeCode', which is for rhs
 330 amodes that might possibly need the extra cast.
 331
 332 \begin{code}
 333 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 334
 335 amodeToStix'{-'-} am@(CVal rr CharRep)
 336     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 337     | otherwise = amodeToStix am
 338
 339 amodeToStix' am = amodeToStix am
 340
 341 -----------
 342 amodeToStix am@(CVal rr CharRep)
 343   | mixedTypeLocn am
 344   = StInd IntRep (amodeToStix (CAddr rr))
 345
 346 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 347
 348 amodeToStix (CAddr (SpRel off))
 349   = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
 350
 351 amodeToStix (CAddr (HpRel off))
 352   = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
 353
 354 amodeToStix (CAddr (NodeRel off))
 355   = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
 356
 357 amodeToStix (CAddr (CIndex base off pk))
 358   = StIndex pk (amodeToStix base) (amodeToStix off)
 359
 360 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 361 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 362
 363 amodeToStix (CLbl      lbl _) = StCLbl lbl
 364
 365  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 366
 367 amodeToStix (CCharLike (CLit (MachChar c)))
 368   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
 369   where
 370     off = charLikeSize * ord c
 371
 372 amodeToStix (CCharLike x)
 373   = StIndex CharRep charLike off
 374   where
 375     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger charLikeSize)]
 376
 377 amodeToStix (CIntLike (CLit (MachInt i _)))
 378   = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
 379   where
 380     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 381
 382 amodeToStix (CIntLike x)
 383   = panic "CIntLike"
 384
 385 amodeToStix (CLit core)
 386   = case core of
 387       MachChar c     -> StInt (toInteger (ord c))
 388       MachStr s      -> StString s
 389       MachAddr a     -> StInt a
 390       MachInt i _    -> StInt (toInteger i)
 391       MachLitLit s _ -> {-trace (_UNPK_ s ++ "\n")-} (litLitToStix (_UNPK_ s))
 392       MachFloat d    -> StDouble d
 393       MachDouble d   -> StDouble d
 394       _ -> panic "amodeToStix:core literal"
 395
 396 amodeToStix (CLitLit s _)
 397    = litLitToStix (_UNPK_ s)
 398
 399 amodeToStix (CMacroExpr _ macro [arg])
 400   = case macro of
 401       ENTRY_CODE -> amodeToStix arg
 402       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 403       GET_TAG    ->
 404 #ifdef WORDS_BIGENDIAN
 405                     StPrim AndOp
 406                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 407                                                 (StInt (toInteger (-1)))),
 408                          StInt 65535]
 409 #else
 410                     StPrim SrlOp
 411                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 412                                                 (StInt (toInteger (-1)))),
 413                          StInt 16]
 414 #endif
 415       UPD_FRAME_UPDATEE
 416          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 417                                          (StInt (toInteger uF_UPDATEE)))
 418 -- XXX!!!
 419 -- GET_TAG(info_ptr) is supposed to be  get_itbl(info_ptr)->srt_len,
 420 -- which we've had to hand-code here.
 421
 422 litLitToStix :: String -> StixTree
 423 litLitToStix nm
 424    = case nm of
 425         "stdout" -> stixFor_stdout
 426         "stderr" -> stixFor_stderr
 427         "stdin"  -> stixFor_stdin
 428         other    -> error ("\nlitLitToStix: can't handle `" ++ nm ++ "'\n"
 429                            ++ "suggested workaround: use flag -fvia-C\n")
 430 \end{code}
 431
 432 Sizes of the CharLike and IntLike closures that are arranged as arrays
 433 in the data segment.  (These are in bytes.)
 434
 435 \begin{code}
 436 -- The INTLIKE base pointer
 437
 438 intLikePtr :: StixTree
 439
 440 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
 441
 442 -- The CHARLIKE base
 443
 444 charLike :: StixTree
 445
 446 charLike = sStLitLbl SLIT("CHARLIKE_closure")
 447
 448 -- Trees for the ErrorIOPrimOp
 449
 450 topClosure, errorIO :: StixTree
 451
 452 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 453 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 454
 455 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
 456
 457 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 458 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 459 \end{code}