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