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, bLOCK_SIZE,
  23                           rESERVED_STACK_WORDS )
  24 import CLabel           ( mkIntlikeClosureLabel, mkCharlikeClosureLabel,
  25                           mkForeignLabel )
  26 import ForeignCall      ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
  27                           CCallConv(..), playSafe, playThreadSafe )
  28 import Outputable
  29 import Util             ( notNull )
  30 import FastString
  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@.
  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 ToDo: saving/restoring of volatile regs around ccalls.
  58
  59 JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
  60 rather than inheriting the calling convention of the thing which we're really
  61 calling.
  62
  63 \begin{code}
  64 foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
  65
  66   | not (playSafe safety)
  67   = returnUs (\xs -> ccall : xs)
  68
  69   | otherwise
  70   = save_thread_state `thenUs` \ save ->
  71     load_thread_state `thenUs` \ load ->
  72     getUniqueUs       `thenUs` \ uniq ->
  73     let
  74        id  = StixTemp (StixVReg uniq IntRep)
  75
  76        is_threadSafe
  77         | playThreadSafe safety = 1
  78         | otherwise             = 0
  79
  80        suspend = StAssignReg IntRep id
  81                  (StCall (Left FSLIT("suspendThread")) {-no:cconv-} CCallConv
  82                          IntRep [StReg stgBaseReg, StInt is_threadSafe ])
  83        resume  = StVoidable
  84                  (StCall (Left FSLIT("resumeThread")) {-no:cconv-} CCallConv
  85                          VoidRep [StReg id, StInt is_threadSafe ])
  86     in
  87     returnUs (\xs -> save (suspend : ccall : resume : load xs))
  88
  89   where
  90     (cargs, stix_target)
  91         = case ctarget of
  92              StaticTarget nm -> (rhs, Left nm)
  93              DynamicTarget |  notNull rhs -- an assertion
  94                            -> (tail rhs, Right (amodeToStix (head rhs)))
  95
  96     stix_args = map amodeToStix' cargs
  97
  98     ccall = case lhs of
  99       []    -> StVoidable (StCall stix_target cconv VoidRep stix_args)
 100       [lhs] -> mkStAssign pk lhs' (StCall stix_target cconv pk stix_args)
 101             where
 102                lhs' = amodeToStix lhs
 103                pk   = case getAmodeRep lhs of
 104                         FloatRep  -> FloatRep
 105                         DoubleRep -> DoubleRep
 106                         Int64Rep  -> Int64Rep
 107                         Word64Rep -> Word64Rep
 108                         other     -> IntRep
 109
 110 -- a bit late to catch this here..
 111 foreignCallCode _ DNCall{} _
 112  = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
 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 (CAddr (SpRel off))
 142   = StIndex PtrRep (StReg stgSp) (StInt (toInteger (iBox off)))
 143
 144 amodeToStix (CAddr (HpRel off))
 145   = StIndex IntRep (StReg stgHp) (StInt (toInteger (- (iBox off))))
 146
 147 amodeToStix (CAddr (NodeRel off))
 148   = StIndex IntRep (StReg stgNode) (StInt (toInteger (iBox off)))
 149
 150 amodeToStix (CAddr (CIndex base off pk))
 151   = StIndex pk (amodeToStix base) (amodeToStix off)
 152
 153 amodeToStix (CReg magic)    = StReg (StixMagicId magic)
 154 amodeToStix (CTemp uniq pk) = StReg (StixTemp (StixVReg uniq pk))
 155
 156 amodeToStix (CLbl      lbl _) = StCLbl lbl
 157
 158  -- For CharLike and IntLike, we attempt some trivial constant-folding here.
 159
 160 amodeToStix (CCharLike (CLit (MachChar c)))
 161   = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off))
 162   where
 163     off = charLikeSize * (c - mIN_CHARLIKE)
 164
 165 amodeToStix (CCharLike x)
 166   = panic "amodeToStix.CCharLike"
 167
 168 amodeToStix (CIntLike (CLit (MachInt i)))
 169   = StIndex Word8Rep iNTLIKE_closure (StInt (toInteger off))
 170   where
 171     off = intLikeSize * (fromInteger (i - mIN_INTLIKE))
 172
 173 amodeToStix (CIntLike x)
 174   = panic "amodeToStix.CIntLike"
 175
 176 amodeToStix (CLit core)
 177   = case core of
 178       MachChar c     -> StInt (toInteger c)
 179       MachStr s      -> StString s
 180       MachNullAddr   -> StInt 0
 181       MachInt i      -> StInt i
 182       MachWord w     -> case word2IntLit core of MachInt iw -> StInt iw
 183                                                        -- dreadful, but rare.
 184       MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
 185       MachLabel l _        -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
 186       MachFloat d    -> StFloat d
 187       MachDouble d   -> StDouble d
 188       _ -> panic "amodeToStix:core literal"
 189
 190 amodeToStix (CMacroExpr _ macro [arg])
 191   = let
 192         arg_amode = amodeToStix arg
 193     in
 194     case macro of
 195       ENTRY_CODE -> arg_amode
 196       ARG_TAG    -> arg_amode -- just an integer no. of words
 197       GET_TAG    ->
 198 #ifdef WORDS_BIGENDIAN
 199                     StMachOp MO_Nat_And
 200                         [StInd WordRep (StIndex PtrRep arg_amode
 201                                                 (StInt (toInteger (-1)))),
 202                          StInt 65535]
 203 #else
 204                     StMachOp MO_Nat_Shr
 205                         [StInd WordRep (StIndex PtrRep arg_amode
 206                                                 (StInt (toInteger (-1)))),
 207                          StInt 16]
 208 #endif
 209       BYTE_ARR_CTS -> StIndex IntRep arg_amode arrWordsHS
 210       PTRS_ARR_CTS -> StIndex PtrRep arg_amode arrPtrsHS
 211       ForeignObj_CLOSURE_DATA -> StInd PtrRep (StIndex PtrRep arg_amode fixedHS)
 212
 213
 214 amodeToStix other
 215    = pprPanic "StixPrim.amodeToStix" (pprAmode other)
 216 \end{code}
 217
 218 Sizes of the CharLike and IntLike closures that are arranged as arrays
 219 in the data segment.  (These are in bytes.)
 220
 221 \begin{code}
 222 -- The INTLIKE base pointer
 223
 224 iNTLIKE_closure :: StixExpr
 225 iNTLIKE_closure = StCLbl mkIntlikeClosureLabel
 226
 227 -- The CHARLIKE base
 228
 229 cHARLIKE_closure :: StixExpr
 230 cHARLIKE_closure = StCLbl mkCharlikeClosureLabel
 231
 232 -- these are the sizes of charLike and intLike closures, in _bytes_.
 233 charLikeSize = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
 234 intLikeSize  = (fixedHdrSize + 1) * (getPrimRepSizeInBytes PtrRep)
 235 \end{code}
 236
 237
 238 \begin{code}
 239 save_thread_state
 240    = getUniqueUs   `thenUs` \ tso_uq ->
 241      let tso = StixTemp (StixVReg tso_uq PtrRep) in
 242      returnUs (\xs ->
 243         StAssignReg PtrRep tso (StReg stgCurrentTSO)
 244         : StAssignMem PtrRep
 245              (StMachOp MO_Nat_Add
 246                        [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))])
 247              (StReg stgSp)
 248         : StAssignMem PtrRep
 249              (StMachOp MO_Nat_Add
 250                        [StReg stgCurrentNursery,
 251                         StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))])
 252              (StMachOp MO_Nat_Add
 253                        [StReg stgHp, StInt (toInteger (1 * BYTES_PER_WORD))])
 254         : xs
 255      )
 256
 257 load_thread_state
 258    = getUniqueUs   `thenUs` \ tso_uq ->
 259      let tso = StixTemp (StixVReg tso_uq PtrRep) in
 260      returnUs (\xs ->
 261         StAssignReg PtrRep tso (StReg stgCurrentTSO)
 262         : StAssignReg PtrRep
 263              stgSp
 264              (StInd PtrRep
 265                   (StMachOp MO_Nat_Add
 266                             [StReg tso, StInt (toInteger (TSO_SP*BYTES_PER_WORD))]))
 267         : StAssignReg PtrRep
 268              stgSpLim
 269              (StMachOp MO_Nat_Add
 270                        [StReg tso,
 271                         StInt (toInteger ((TSO_STACK + rESERVED_STACK_WORDS)
 272                                           *BYTES_PER_WORD))])
 273         : StAssignReg PtrRep
 274              stgHp
 275              (StMachOp MO_Nat_Sub
 276                        [StInd PtrRep
 277                               (StMachOp MO_Nat_Add
 278                                         [StReg stgCurrentNursery,
 279                                          StInt (toInteger (BDESCR_FREE * BYTES_PER_WORD))]),
 280                         StInt (toInteger (1 * BYTES_PER_WORD))
 281                        ])
 282         : StAssignReg PtrRep
 283              stgHpLim
 284              (StIndex Word8Rep
 285                 (StInd PtrRep
 286                        (StIndex PtrRep (StReg stgCurrentNursery)
 287                                        (StInt (toInteger BDESCR_START))
 288                        )
 289                 )
 290                 (StMachOp MO_Nat_Sub
 291                    [StMachOp MO_NatU_Mul
 292                       [StInd WordRep
 293                              (StIndex PtrRep (StReg stgCurrentNursery)
 294                                              (StInt (toInteger BDESCR_BLOCKS))),
 295                        StInt (toInteger bLOCK_SIZE{-in bytes-})
 296                       ],
 297                       StInt (1 * BYTES_PER_WORD)
 298                    ]
 299                 )
 300
 301              )
 302
 303         : xs
 304      )
 305 \end{code}