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 (CCall (CCallSpec (StaticTarget fn) 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 SLIT("suspendThread") {-no:cconv-} CCallConv
  81                          IntRep [StReg stgBaseReg])
  82        resume  = StVoidable
  83                  (StCall SLIT("resumeThread") {-no:cconv-} CCallConv
  84                          VoidRep [StReg id])
  85     in
  86     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  87
  88   where
  89     args = map amodeCodeForCCall rhs
  90     amodeCodeForCCall x =
  91         let base = amodeToStix' x
  92         in
  93             case getAmodeRep x of
  94               ArrayRep      -> StIndex PtrRep base arrPtrsHS
  95               ByteArrayRep  -> StIndex IntRep base arrWordsHS
  96               ForeignObjRep -> StInd PtrRep (StIndex PtrRep base fixedHS)
  97               _ -> base
  98
  99     ccall = case lhs of
 100       []    -> StVoidable (StCall fn cconv VoidRep args)
 101       [lhs] -> mkStAssign pk lhs' (StCall fn cconv pk args)
 102             where
 103                lhs' = amodeToStix lhs
 104                pk   = case getAmodeRep lhs of
 105                         FloatRep  -> FloatRep
 106                         DoubleRep -> DoubleRep
 107                         Int64Rep  -> Int64Rep
 108                         Word64Rep -> Word64Rep
 109                         other     -> IntRep
 110
 111 foreignCallCode lhs call rhs
 112   = ncgPrimopMoan "Native code generator can't handle foreign call" (ppr call)
 113 \end{code}
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsubsection{Code for @CAddrMode@s}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 When a character is fetched from a mixed type location, we have to do
 122 an extra cast.  This is reflected in amodeCode', which is for rhs
 123 amodes that might possibly need the extra cast.
 124
 125 \begin{code}
 126 amodeToStix, amodeToStix' :: CAddrMode -> StixExpr
 127
 128 amodeToStix'{-'-} am@(CVal rr CharRep)
 129   | mixedTypeLocn am = StMachOp MO_NatS_to_32U [amodeToStix am]
 130   | otherwise        = amodeToStix am
 131 amodeToStix' am
 132   = amodeToStix am
 133
 134 -----------
 135 amodeToStix am@(CVal rr CharRep)
 136   | mixedTypeLocn am
 137   = StInd IntRep (amodeToStix (CAddr rr))
 138
 139 amodeToStix (CVal rr pk) = StInd pk (amodeToStix (CAddr rr))
 140
 141 amodeToStix CBytesPerWord
 142   = StInt (toInteger wORD_SIZE)
 143
 144 amodeToStix (CMem pk addr) = StInd pk (amodeToStix addr)
 145
 146 amodeToStix (CAddr (SpRel off))
 147   = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
 148
 149 amodeToStix (CAddr (HpRel off))
 150   = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
 151
 152 amodeToStix (CAddr (NodeRel off))
 153   = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
 154
 155 amodeToStix (CAddr (CIndex base off pk))
 156   = StIndex pk (amodeToStix base) (amodeToStix off)
 157
 158 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 159 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
 160
 161 amodeToStix (CLbl      lbl _) = StCLbl lbl
 162
 163  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 164
 165 amodeToStix (CCharLike (CLit (MachChar c)))
 166   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 167   where
 168     off = charLikeSize * (c - mIN_CHARLIKE)
 169
 170 amodeToStix (CCharLike x)
 171   = panic "amodeToStix.CCharLike"
 172
 173 amodeToStix (CIntLike (CLit (MachInt i)))
 174   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 175   where
 176     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 177
 178 amodeToStix (CIntLike x)
 179   = panic "amodeToStix.CIntLike"
 180
 181 amodeToStix (CLit core)
 182   = case core of
 183       MachChar c     -> StInt (toInteger c)
 184       MachStr s      -> StString s
 185       MachAddr a     -> StInt a
 186       MachInt i      -> StInt i
 187       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 188       MachLitLit s _ -> litLitErr
 189       MachLabel l    -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 190       MachFloat d    -> StFloat d
 191       MachDouble d   -> StDouble d
 192       _ -> panic "amodeToStix:core literal"
 193
 194 amodeToStix (CMacroExpr _ macro [arg])
 195   = case macro of
 196       ENTRY_CODE -> amodeToStix arg
 197       ARG_TAG    -> amodeToStix arg -- just an integer no. of words
 198       GET_TAG    ->
 199 #ifdef WORDS_BIGENDIAN
 200                     StMachOp MO_Nat_And
 201                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 202                                                 (StInt (toInteger (-1)))),
 203                          StInt 65535]
 204 #else
 205                     StMachOp MO_Nat_Shr
 206                         [StInd WordRep (StIndex PtrRep (amodeToStix arg)
 207                                                 (StInt (toInteger (-1)))),
 208                          StInt 16]
 209 #endif
 210       UPD_FRAME_UPDATEE
 211          -> StInd PtrRep (StIndex PtrRep (amodeToStix arg)
 212                                          (StInt (toInteger uF_UPDATEE)))
 213
 214 amodeToStix other
 215    = pprPanic "StixPrim.amodeToStix" (pprAmode other)
 216
 217 litLitErr
 218    = ncgPrimopMoan "native code generator can't handle lit-lits" empty
 219 \end{code}
 220
 221 Sizes of the CharLike and IntLike closures that are arranged as arrays
 222 in the data segment.  (These are in bytes.)
 223
 224 \begin{code}
 225 -- The INTLIKE base pointer
 226
 227 iNTLIKE_closure :: StixExpr
 228 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 229
 230 -- The CHARLIKE base
 231
 232 cHARLIKE_closure :: StixExpr
 233 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 234
 235 mutArrPtrsFrozen_info = StCLbl mkMAP_FROZEN_infoLabel
 236
 237 -- these are the sizes of charLike and intLike closures, in _bytes_.
 238 charLikeSize = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 239 intLikeSize  = (fixedHdrSize + 1) * (getPrimRepArrayElemSize PtrRep)
 240 \end{code}
 241
 242
 243 \begin{code}
 244 save_thread_state
 245    = getUniqueUs   `thenUs` \ tso_uq ->
 246      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 247      returnUs (\xs ->
 248         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 249         : StAssignMem PtrRep
 250              (StMachOp MO_Nat_Add
 251                        [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
 252              (StReg stgSp)
 253         : StAssignMem PtrRep
 254              (StMachOp MO_Nat_Add
 255                        [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))])
 256              (StReg stgSu)
 257         : StAssignMem PtrRep
 258              (StMachOp MO_Nat_Add
 259                        [StReg stgCurrentNursery,
 260                         StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
 261              (StMachOp MO_Nat_Add
 262                        [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
 263         : xs
 264      )
 265
 266 load_thread_state
 267    = getUniqueUs   `thenUs` \ tso_uq ->
 268      let tso = StixTemp (StixVReg tso_uq ThreadIdRep) in
 269      returnUs (\xs ->
 270         StAssignReg ThreadIdRep tso (StReg stgCurrentTSO)
 271         : StAssignReg PtrRep
 272              stgSp
 273              (StInd PtrRep
 274                   (StMachOp MO_Nat_Add
 275                             [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 276         : StAssignReg PtrRep
 277              stgSu
 278              (StInd PtrRep
 279                   (StMachOp MO_Nat_Add
 280                             [StReg tso, StInt (toInteger (TSO_SU*BYTES_PER_WORD))]))
 281         : StAssignReg PtrRep
 282              stgSpLim
 283              (StMachOp MO_Nat_Add
 284                        [StReg tso,
 285                         StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 286                                           *BYTES_PER_WORD))])
 287         : StAssignReg PtrRep
 288              stgHp
 289              (StMachOp MO_Nat_Sub
 290                        [StInd PtrRep
 291                               (StMachOp MO_Nat_Add
 292                                         [StReg stgCurrentNursery,
 293                                          StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 294                         StInt (toInteger (1 * BYTES_PER_WORD))
 295                        ])
 296         : StAssignReg PtrRep
 297              stgHpLim
 298              (StIndex Word8Rep
 299                 (StInd PtrRep
 300                        (StIndex PtrRep (StReg stgCurrentNursery)
 301                                        (StInt (toInteger BDESCR_START))
 302                        )
 303                 )
 304                 (StMachOp MO_Nat_Sub
 305                    [StMachOp MO_NatU_Mul
 306                       [StInd WordRep
 307                              (StIndex PtrRep (StReg stgCurrentNursery)
 308                                              (StInt (toInteger BDESCR_BLOCKS))),
 309                        StInt (toInteger bLOCK_SIZE{-in bytes-})
 310                       ],
 311                       StInt (1 * BYTES_PER_WORD)
 312                    ]
 313                 )
 314
 315              )
 316
 317         : xs
 318      )
 319 \end{code}