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