ghc/compiler/nativeGen/StixPrim.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixPrim ( amodeToStix, amodeToStix', foreignCallCode )
   7 where
   8
   9 #include "HsVersions.h"
  10
  11 import MachMisc
  12 import Stix
  13
  14 import PprAbsC          ( pprAmode )
  15 import AbsCSyn          hiding ( spRel )
  16 import AbsCUtils        ( getAmodeRep, mixedTypeLocn )
  17 import SMRep            ( fixedHdrSize )
  18 import Literal          ( Literal(..), word2IntLit )
  19 import MachOp           ( MachOp(..) )
  20 import PrimRep          ( PrimRep(..), getPrimRepArrayElemSize )
  21 import UniqSupply       ( returnUs, thenUs, getUniqueUs, UniqSM )
  22 import Constants        ( wORD_SIZE,
  23                           mIN_INTLIKE, mIN_CHARLIKE, uF_UPDATEE, bLOCK_SIZE,
  24                           rESERVED_STACK_WORDS )
  25 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  26                           mkMAP_FROZEN_infoLabel, mkEMPTY_MVAR_infoLabel,
  27                           mkForeignLabel )
  28 import ForeignCall      ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
  29                           CCallConv(..), playSafe )
  30 import Outputable
  31 import FastTypes
  32
  33 #include "NCG.h"
  34 \end{code}
  35
  36 The main honchos here are primCode and foreignCallCode, which handle the guts of COpStmts.
  37
  38 \begin{code}
  39 foreignCallCode
  40     :: [CAddrMode]      -- results
  41     -> ForeignCall      -- op
  42     -> [CAddrMode]      -- args
  43     -> UniqSM StixStmtList
  44 \end{code}
  45
  46 %************************************************************************
  47 %*                                                                      *
  48 \subsubsection{Code for foreign calls}
  49 %*                                                                      *
  50 %************************************************************************
  51
  52 First, the dreaded @ccall@.  We can't handle @casm@s.
  53
  54 Usually, this compiles to an assignment, but when the left-hand side
  55 is empty, we just perform the call and ignore the result.
  56
  57 btw Why not let programmer use casm to provide assembly code instead
  58 of C code?  ADR
  59
  60 ToDo: saving/restoring of volatile regs around ccalls.
  61
  62 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
  63 rather than inheriting the calling convention of the thing which we're really
  64 calling.
  65
  66 \begin{code}
  67 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
  68
  69   | not (playSafe safety)
  70   = returnUs (\xs -> ccall : xs)
  71
  72   | otherwise
  73   = save_thread_state   `thenUs` \ save ->
  74     load_thread_state   `thenUs` \ load ->
  75     getUniqueUs         `thenUs` \ uniq ->
  76     let
  77        id  = StixTemp (StixVReg uniq IntRep)
  78
  79        suspend = StAssignReg IntRep id
  80                  (StCall (Left SLIT("suspendThread")) {-no:cconv-} CCallConv
  81                          IntRep [StReg stgBaseReg])
  82        resume  = StVoidable
  83                  (StCall (Left SLIT("resumeThread")) {-no:cconv-} CCallConv
  84                          VoidRep [StReg id])
  85     in
  86     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  87
  88   where
  89     (cargs, stix_target)
  90         = case ctarget of
  91              StaticTarget nm -> (rhs, Left nm)
  92              DynamicTarget |  not (null rhs) -- an assertion
  93                            -> (tail rhs, Right (amodeToStix (head rhs)))
  94              CasmTarget _
  95                 -> ncgPrimopMoan "Native code generator can't handle foreign call"
  96                                  (ppr call)
  97
  98     stix_args = map amodeCodeForCCall cargs
  99     amodeCodeForCCall x =
 100         let base = amodeToStix' x
 101         in
 102             case getAmodeRep x of
 103               ArrayRep      -> StIndex PtrRep base arrPtrsHS
 104               ByteArrayRep  -> StIndex IntRep base arrWordsHS
 105               ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
 106               other         -> base
 107
 108     ccall = case lhs of
 109       []    -> StVoidable (StCall stix_target cconv VoidRep stix_args)
 110       [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
 111             where
 112                lhs' = amodeToStix lhs
 113                pk   = case getAmodeRep lhs of
 114                         FloatRep  -> FloatRep
 115                         DoubleRep -> DoubleRep
 116                         Int64Rep  -> Int64Rep
 117                         Word64Rep -> Word64Rep
 118                         other     -> IntRep
 119 \end{code}
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsubsection{Code for @CAddrMode@s}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 When a character is fetched from a mixed type location, we have to do
 128 an extra cast.  This is reflected in amodeCode', which is for rhs
 129 amodes that might possibly need the extra cast.
 130
 131 \begin{code}
 132 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
 133
 134 amodeToStix'{-'-} am@(CVal rr CharRep)
 135   | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
 136   | otherwise        = amodeToStix am
 137 amodeToStix' am
 138   = amodeToStix am
 139
 140 -----------
 141 amodeToStix am@(CVal rr CharRep)
 142   | mixedTypeLocn am
 143   = StInd IntRep (amodeToStix (CAddr rr))
 144
 145 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 146
 147 amodeToStix CBytesPerWord
 148   = StInt (toInteger wORD_SIZE)
 149
 150 amodeToStix (CMem pk addr) = StInd pk (amodeToStix addr)
 151
 152 amodeToStix (CAddr (SpRel off))
 153   = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
 154
 155 amodeToStix (CAddr (HpRel off))
 156   = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
 157
 158 amodeToStix (CAddr (NodeRel off))
 159   = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
 160
 161 amodeToStix (CAddr (CIndex base off pk))
 162   = StIndex pk (amodeToStix base) (amodeToStix off)
 163
 164 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 165 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
 166
 167 amodeToStix (CLbl      lbl _) = StCLbl lbl
 168
 169  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 170
 171 amodeToStix (CCharLike (CLit (MachChar c)))
 172   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 173   where
 174     off = charLikeSize * (c - mIN_CHARLIKE)
 175
 176 amodeToStix (CCharLike x)
 177   = panic "amodeToStix.CCharLike"
 178
 179 amodeToStix (CIntLike (CLit (MachInt i)))
 180   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 181   where
 182     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 183
 184 amodeToStix (CIntLike x)
 185   = panic "amodeToStix.CIntLike"
 186
 187 amodeToStix (CLit core)
 188   = case core of
 189       MachChar c     -> StInt (toInteger c)
 190       MachStr s      -> StString s
 191       MachAddr a     -> StInt a
 192       MachInt i      -> StInt i
 193       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 194       MachLitLit s _ -> litLitErr
 195       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 196       MachFloat d    -> StFloat d
 197       MachDouble d   -> StDouble d
 198       _ -> panic "amodeToStix:core literal"
 199
 200 amodeToStix (CMacroExpr _ macro [arg])
 201   = case macro of
 202       ENTRY_CODE -> amodeToStix arg
 203       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 204       GET_TAG    ->
 205 #ifdef WORDS_BIGENDIAN
 206                     StMachOp MO_Nat_And
 207                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 208                                                 (StInt (toInteger (-1)))),
 209                          StInt 65535]
 210 #else
 211                     StMachOp MO_Nat_Shr
 212                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 213                                                 (StInt (toInteger (-1)))),
 214                          StInt 16]
 215 #endif
 216       UPD_FRAME_UPDATEE
 217          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 218                                          (StInt (toInteger uF_UPDATEE)))
 219
 220 amodeToStix other
 221    = pprPanic "StixPrim.amodeToStix" (pprAmode other)
 222
 223 litLitErr
 224    = ncgPrimopMoan "native code generator can't handle lit-lits" empty
 225 \end{code}
 226
 227 Sizes of the CharLike and IntLike closures that are arranged as arrays
 228 in the data segment.  (These are in bytes.)
 229
 230 \begin{code}
 231 -- The INTLIKE base pointer
 232
 233 iNTLIKE_closure :: StixExpr
 234 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 235
 236 -- The CHARLIKE base
 237
 238 cHARLIKE_closure :: StixExpr
 239 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 240
 241 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 242
 243 -- these are the sizes of charLike and intLike closures, in _bytes_.
 244 charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 245 intLikeSize  = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 246 \end{code}
 247
 248
 249 \begin{code}
 250 save_thread_state
 251    = getUniqueUs   `thenUs` \ tso_uq ->
 252      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 253      returnUs (\xs ->
 254         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 255         : StAssignMem PtrRep
 256              (StMachOp MO_Nat_Add
 257                        [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
 258              (StReg stgSp)
 259         : StAssignMem PtrRep
 260              (StMachOp MO_Nat_Add
 261                        [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
 262              (StReg stgSu)
 263         : StAssignMem PtrRep
 264              (StMachOp MO_Nat_Add
 265                        [StReg stgCurrentNursery,
 266                         StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
 267              (StMachOp MO_Nat_Add
 268                        [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
 269         : xs
 270      )
 271
 272 load_thread_state
 273    = getUniqueUs   `thenUs` \ tso_uq ->
 274      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 275      returnUs (\xs ->
 276         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 277         : StAssignReg PtrRep
 278              stgSp
 279              (StInd PtrRep
 280                   (StMachOp MO_Nat_Add
 281                             [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 282         : StAssignReg PtrRep
 283              stgSu
 284              (StInd PtrRep
 285                   (StMachOp MO_Nat_Add
 286                             [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 287         : StAssignReg PtrRep
 288              stgSpLim
 289              (StMachOp MO_Nat_Add
 290                        [StReg tso,
 291                         StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 292                                           *BYTES_PER_WORD))])
 293         : StAssignReg PtrRep
 294              stgHp
 295              (StMachOp MO_Nat_Sub
 296                        [StInd PtrRep
 297                               (StMachOp MO_Nat_Add
 298                                         [StReg stgCurrentNursery,
 299                                          StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 300                         StInt (toInteger (1 * BYTES_PER_WORD))
 301                        ])
 302         : StAssignReg PtrRep
 303              stgHpLim
 304              (StIndex Word8Rep
 305                 (StInd PtrRep
 306                        (StIndex PtrRep (StReg stgCurrentNursery)
 307                                        (StInt (toInteger BDESCR_START))
 308                        )
 309                 )
 310                 (StMachOp MO_Nat_Sub
 311                    [StMachOp MO_NatU_Mul
 312                       [StInd WordRep
 313                              (StIndex PtrRep (StReg stgCurrentNursery)
 314                                              (StInt (toInteger BDESCR_BLOCKS))),
 315                        StInt (toInteger bLOCK_SIZE{-in bytes-})
 316                       ],
 317                       StInt (1 * BYTES_PER_WORD)
 318                    ]
 319                 )
 320
 321              )
 322
 323         : xs
 324      )
 325 \end{code}