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 SMRep            ( fixedHdrSize )
  18 import Const            ( Literal(..) )
  19 import CallConv         ( cCallConv )
  20 import PrimOp           ( PrimOp(..) )
  21 import PrimRep          ( PrimRep(..), isFloatingRep )
  22 import UniqSupply       ( returnUs, thenUs, UniqSM )
  23 import Constants        ( mIN_INTLIKE )
  24 import Outputable
  25
  26 import Char             ( ord )
  27 \end{code}
  28
  29 The main honcho here is primCode, which handles the guts of COpStmts.
  30
  31 \begin{code}
  32 primCode
  33     :: [CAddrMode]      -- results
  34     -> PrimOp           -- op
  35     -> [CAddrMode]      -- args
  36     -> UniqSM StixTreeList
  37 \end{code}
  38
  39 First, the dreaded @ccall@.  We can't handle @casm@s.
  40
  41 Usually, this compiles to an assignment, but when the left-hand side
  42 is empty, we just perform the call and ignore the result.
  43
  44 btw Why not let programmer use casm to provide assembly code instead
  45 of C code?  ADR
  46
  47 The (MP) integer operations are a true nightmare.  Since we don't have
  48 a convenient abstract way of allocating temporary variables on the (C)
  49 stack, we use the space just below HpLim for the @MP_INT@ structures,
  50 and modify our heap check accordingly.
  51
  52 \begin{code}
  53 -- NB: ordering of clauses somewhere driven by
  54 -- the desire to getting sane patt-matching behavior
  55 primCode res@[ar,sr,dr] IntegerNegOp arg@[aa,sa,da]
  56   = gmpNegate (ar,sr,dr) (aa,sa,da)
  57 \end{code}
  58
  59 \begin{code}
  60 primCode [res] IntegerCmpOp args@[aa1,sa1,da1, aa2,sa2,da2]
  61   = gmpCompare res (aa1,sa1,da1, aa2,sa2,da2)
  62
  63 primCode [res] Integer2IntOp arg@[aa,sa,da]
  64   = gmpInteger2Int res (aa,sa,da)
  65
  66 primCode [res] Integer2WordOp arg@[aa,sa,da]
  67   = gmpInteger2Word res (aa,sa,da)
  68
  69 primCode [res] Int2AddrOp [arg]
  70   = simpleCoercion AddrRep res arg
  71
  72 primCode [res] Addr2IntOp [arg]
  73   = simpleCoercion IntRep res arg
  74
  75 primCode [res] Int2WordOp [arg]
  76   = simpleCoercion IntRep{-WordRep?-} res arg
  77
  78 primCode [res] Word2IntOp [arg]
  79   = simpleCoercion IntRep res arg
  80 \end{code}
  81
  82 \begin{code}
  83 primCode [res] SameMutableArrayOp args
  84   = let
  85         compare = StPrim AddrEqOp (map amodeToStix args)
  86         assign = StAssign IntRep (amodeToStix res) compare
  87     in
  88     returnUs (\xs -> assign : xs)
  89
  90 primCode res@[_] SameMutableByteArrayOp args
  91   = primCode res SameMutableArrayOp args
  92 \end{code}
  93
  94 Freezing an array of pointers is a double assignment.  We fix the
  95 header of the ``new'' closure because the lhs is probably a better
  96 addressing mode for the indirection (most likely, it's a VanillaReg).
  97
  98 \begin{code}
  99
 100 primCode [lhs] UnsafeFreezeArrayOp [rhs]
 101   = let
 102         lhs' = amodeToStix lhs
 103         rhs' = amodeToStix rhs
 104         header = StInd PtrRep lhs'
 105         assign = StAssign PtrRep lhs' rhs'
 106         freeze = StAssign PtrRep header mutArrPtrsFrozen_info
 107     in
 108     returnUs (\xs -> assign : freeze : xs)
 109
 110 primCode [lhs] UnsafeFreezeByteArrayOp [rhs]
 111   = simpleCoercion PtrRep lhs rhs
 112 \end{code}
 113
 114 Returning the size of (mutable) byte arrays is just
 115 an indexing operation.
 116
 117 \begin{code}
 118 primCode [lhs] SizeofByteArrayOp [rhs]
 119   = let
 120         lhs' = amodeToStix lhs
 121         rhs' = amodeToStix rhs
 122         sz   = StIndex IntRep rhs' fixedHS
 123         assign = StAssign IntRep lhs' (StInd IntRep sz)
 124     in
 125     returnUs (\xs -> assign : xs)
 126
 127 primCode [lhs] SizeofMutableByteArrayOp [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 \end{code}
 137
 138 Most other array primitives translate to simple indexing.
 139
 140 \begin{code}
 141
 142 primCode lhs@[_] IndexArrayOp args
 143   = primCode lhs ReadArrayOp args
 144
 145 primCode [lhs] ReadArrayOp [obj, ix]
 146   = let
 147         lhs' = amodeToStix lhs
 148         obj' = amodeToStix obj
 149         ix' = amodeToStix ix
 150         base = StIndex IntRep obj' arrHS
 151         assign = StAssign PtrRep lhs' (StInd PtrRep (StIndex PtrRep base ix'))
 152     in
 153     returnUs (\xs -> assign : xs)
 154
 155 primCode [] WriteArrayOp [obj, ix, v]
 156   = let
 157         obj' = amodeToStix obj
 158         ix' = amodeToStix ix
 159         v' = amodeToStix v
 160         base = StIndex IntRep obj' arrHS
 161         assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
 162     in
 163     returnUs (\xs -> assign : xs)
 164
 165 primCode lhs@[_] (IndexByteArrayOp pk) args
 166   = primCode lhs (ReadByteArrayOp pk) args
 167
 168 -- NB: indexing in "pk" units, *not* in bytes (WDP 95/09)
 169
 170 primCode [lhs] (ReadByteArrayOp pk) [obj, ix]
 171   = let
 172         lhs' = amodeToStix lhs
 173         obj' = amodeToStix obj
 174         ix' = amodeToStix ix
 175         base = StIndex IntRep obj' arrHS
 176         assign = StAssign pk lhs' (StInd pk (StIndex pk base ix'))
 177     in
 178     returnUs (\xs -> assign : xs)
 179
 180 primCode [lhs] (IndexOffAddrOp pk) [obj, ix]
 181   = let
 182         lhs' = amodeToStix lhs
 183         obj' = amodeToStix obj
 184         ix' = amodeToStix ix
 185         assign = StAssign pk lhs' (StInd pk (StIndex pk obj' ix'))
 186     in
 187     returnUs (\xs -> assign : xs)
 188
 189 primCode [lhs] (IndexOffForeignObjOp pk) [obj, ix]
 190   = let
 191         lhs' = amodeToStix lhs
 192         obj' = amodeToStix obj
 193         ix' = amodeToStix ix
 194         obj'' = StIndex PtrRep obj' fixedHS
 195         assign = StAssign pk lhs' (StInd pk (StIndex pk obj'' ix'))
 196     in
 197     returnUs (\xs -> assign : xs)
 198
 199 primCode [] (WriteByteArrayOp pk) [obj, ix, v]
 200   = let
 201         obj' = amodeToStix obj
 202         ix' = amodeToStix ix
 203         v' = amodeToStix v
 204         base = StIndex IntRep obj' arrHS
 205         assign = StAssign pk (StInd pk (StIndex pk base ix')) v'
 206     in
 207     returnUs (\xs -> assign : xs)
 208 \end{code}
 209
 210 \begin{code}
 211 --primCode lhs (CCallOp fn is_asm may_gc) rhs
 212 primCode lhs (CCallOp (Left fn) is_asm may_gc cconv) rhs
 213   | is_asm = error "ERROR: Native code generator can't handle casm"
 214   | may_gc = error "ERROR: Native code generator can't handle _ccall_GC_\n"
 215   | otherwise
 216   = case lhs of
 217       [] -> returnUs (\xs -> (StCall fn cconv VoidRep args) : xs)
 218       [lhs] ->
 219           let lhs' = amodeToStix lhs
 220               pk = if isFloatingRep (getAmodeRep lhs) then DoubleRep else IntRep
 221               call = StAssign pk lhs' (StCall fn cconv pk args)
 222           in
 223               returnUs (\xs -> call : xs)
 224   where
 225     args = map amodeCodeForCCall rhs
 226     amodeCodeForCCall x =
 227         let base = amodeToStix' x
 228         in
 229             case getAmodeRep x of
 230               ArrayRep      -> StIndex PtrRep base arrHS
 231               ByteArrayRep  -> StIndex IntRep base arrHS
 232               ForeignObjRep -> StIndex PtrRep base fixedHS
 233               _ -> base
 234 \end{code}
 235
 236 Now the more mundane operations.
 237
 238 \begin{code}
 239 primCode lhs op rhs
 240   = let
 241         lhs' = map amodeToStix  lhs
 242         rhs' = map amodeToStix' rhs
 243         pk   = getAmodeRep (head lhs)
 244     in
 245     returnUs (\ xs -> simplePrim pk lhs' op rhs' : xs)
 246 \end{code}
 247
 248 \begin{code}
 249 simpleCoercion
 250       :: PrimRep
 251       -> CAddrMode
 252       -> CAddrMode
 253       -> UniqSM StixTreeList
 254
 255 simpleCoercion pk lhs rhs
 256   = returnUs (\xs -> StAssign pk (amodeToStix lhs) (amodeToStix rhs) : xs)
 257 \end{code}
 258
 259 Here we try to rewrite primitives into a form the code generator can
 260 understand.  Any primitives not handled here must be handled at the
 261 level of the specific code generator.
 262
 263 \begin{code}
 264 simplePrim
 265     :: PrimRep          -- Rep of first destination
 266     -> [StixTree]       -- Destinations
 267     -> PrimOp
 268     -> [StixTree]
 269     -> StixTree
 270 \end{code}
 271
 272 Now look for something more conventional.
 273
 274 \begin{code}
 275 simplePrim pk [lhs] op rest  = StAssign pk lhs (StPrim op rest)
 276 simplePrim pk as    op bs    = simplePrim_error op
 277
 278 simplePrim_error op
 279     = 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")
 280 \end{code}
 281
 282 %---------------------------------------------------------------------
 283
 284 Here we generate the Stix code for CAddrModes.
 285
 286 When a character is fetched from a mixed type location, we have to do
 287 an extra cast.  This is reflected in amodeCode', which is for rhs
 288 amodes that might possibly need the extra cast.
 289
 290 \begin{code}
 291 amodeToStix, amodeToStix' :: CAddrMode -> StixTree
 292
 293 amodeToStix'{-'-} am@(CVal rr CharRep)
 294     | mixedTypeLocn am = StPrim ChrOp [amodeToStix am]
 295     | otherwise = amodeToStix am
 296
 297 amodeToStix' am = amodeToStix am
 298
 299 -----------
 300 amodeToStix am@(CVal rr CharRep)
 301   | mixedTypeLocn am
 302   = StInd IntRep (amodeToStix (CAddr rr))
 303
 304 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 305
 306 amodeToStix (CAddr (SpRel off))
 307   = StIndex PtrRep stgSp (StInt (toInteger IBOX(off)))
 308
 309 amodeToStix (CAddr (HpRel off))
 310   = StIndex IntRep stgHp (StInt (toInteger (- IBOX(off))))
 311
 312 amodeToStix (CAddr (NodeRel off))
 313   = StIndex IntRep stgNode (StInt (toInteger IBOX(off)))
 314
 315 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 316 amodeToStix (CTemp uniq pk) = StReg (StixTemp uniq pk)
 317
 318 amodeToStix (CLbl      lbl _) = StCLbl lbl
 319
 320 amodeToStix (CTableEntry base off pk)
 321   = StInd pk (StIndex pk (amodeToStix base) (amodeToStix off))
 322
 323  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 324
 325 amodeToStix (CCharLike (CLit (MachChar c)))
 326   = StLitLbl ((<>) (ptext SLIT("CHARLIKE_closure+")) (int off))
 327   where
 328     off = charLikeSize * ord c
 329
 330 amodeToStix (CCharLike x)
 331   = StIndex PtrRep charLike off
 332   where
 333     off = StPrim IntMulOp [amodeToStix x, StInt (toInteger (fixedHdrSize+1))]
 334
 335 amodeToStix (CIntLike (CLit (MachInt i _)))
 336   = StLitLbl ((<>) (ptext SLIT("INTLIKE_closure+")) (int off))
 337   where
 338     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 339
 340 amodeToStix (CIntLike x)
 341   = panic "CIntLike"
 342
 343  -- A CString is just a (CLit . MachStr)
 344 amodeToStix (CString s) = StString s
 345
 346 amodeToStix (CLit core)
 347   = case core of
 348       MachChar c     -> StInt (toInteger (ord c))
 349       MachStr s      -> StString s
 350       MachAddr a     -> StInt a
 351       MachInt i _    -> StInt (toInteger i)
 352       MachLitLit s _ -> StLitLit s
 353       MachFloat d    -> StDouble d
 354       MachDouble d   -> StDouble d
 355       _ -> panic "amodeToStix:core literal"
 356
 357  -- A CLitLit is just a (CLit . MachLitLit)
 358 amodeToStix (CLitLit s _) = StLitLit s
 359
 360 amodeToStix (CMacroExpr _ macro [arg])
 361   = case macro of
 362       ENTRY_CODE -> amodeToStix arg
 363       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 364       GET_TAG    -> StPrim SrlOp
 365                         [StInd WordRep (StPrim IntSubOp [amodeToStix arg,
 366                                                          StInt 1]),
 367                          StInt 16]
 368
 369 -- XXX!!!
 370 -- GET_TAG(info_ptr) is supposed to be  get_itbl(info_ptr)->srt_len,
 371 -- which we've had to hand-code here.
 372 \end{code}
 373
 374 Sizes of the CharLike and IntLike closures that are arranged as arrays
 375 in the data segment.  (These are in bytes.)
 376
 377 \begin{code}
 378 -- The INTLIKE base pointer
 379
 380 intLikePtr :: StixTree
 381
 382 intLikePtr = StInd PtrRep (sStLitLbl SLIT("INTLIKE_closure"))
 383
 384 -- The CHARLIKE base
 385
 386 charLike :: StixTree
 387
 388 charLike = sStLitLbl SLIT("CHARLIKE_closure")
 389
 390 -- Trees for the ErrorIOPrimOp
 391
 392 topClosure, errorIO :: StixTree
 393
 394 topClosure = StInd PtrRep (sStLitLbl SLIT("TopClosure"))
 395 errorIO = StJump (StInd PtrRep (sStLitLbl SLIT("ErrorIO_innards")))
 396
 397 mutArrPtrsFrozen_info = sStLitLbl SLIT("MUT_ARR_PTRS_FROZEN_info")
 398
 399 charLikeSize = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 400 intLikeSize  = (fixedHdrSize + 1) * (fromInteger (sizeOf PtrRep))
 401 \end{code}