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