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