ghc/compiler/nativeGen/StixMacro.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4
   5 \begin{code}
   6 #include "HsVersions.h"
   7
   8 module StixMacro (
   9         genMacroCode, doHeapCheck, smStablePtrTable,
  10
  11         Target, StixTree, SplitUniqSupply, CAddrMode, CExprMacro,
  12         CStmtMacro
  13     ) where
  14
  15 import AbsCSyn
  16 import AbsPrel      ( PrimOp(..)
  17                       IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  18                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  19                     )
  20 import MachDesc     {- lots -}
  21 import CgCompInfo   ( sTD_UF_SIZE, uF_RET, uF_SUA, uF_SUB, uF_UPDATEE )
  22 import Stix
  23 import SplitUniq
  24 import Unique
  25 import Util
  26
  27 \end{code}
  28
  29 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  30 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  31 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  32 closure address.
  33
  34 \begin{code}
  35 mkIntCLit_0 = mkIntCLit 0 -- out here to avoid CAF (sigh)
  36 mkIntCLit_3 = mkIntCLit 3
  37
  38 genMacroCode
  39     :: Target
  40     -> CStmtMacro           -- statement macro
  41     -> [CAddrMode]          -- args
  42     -> SUniqSM StixTreeList
  43
  44 genMacroCode target ARGS_CHK_A_LOAD_NODE args =
  45     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
  46     let [words, lbl] = map (amodeToStix target) args
  47         temp = StIndex PtrKind stgSpA words
  48         test = StPrim AddrGeOp [stgSuA, temp]
  49         cjmp = StCondJump ulbl test
  50         assign = StAssign PtrKind stgNode lbl
  51         join = StLabel ulbl
  52     in
  53         returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
  54
  55 genMacroCode target ARGS_CHK_A [words] =
  56     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
  57     let temp = StIndex PtrKind stgSpA (amodeToStix target words)
  58         test = StPrim AddrGeOp [stgSuA, temp]
  59         cjmp = StCondJump ulbl test
  60         join = StLabel ulbl
  61     in
  62         returnSUs (\xs -> cjmp : updatePAP : join : xs)
  63
  64 \end{code}
  65
  66 Like the macros above, the @ARGS_CHK_B{_LOAD_NODE}@ macros check for
  67 sufficient arguments on the B stack, and perform a tail call to
  68 @UpdatePAP@ if the arguments are not there.  The @_LOAD_NODE@ version
  69 also loads R1 with an appropriate closure address.  Note that the
  70 directions are swapped relative to the A stack.
  71
  72 \begin{code}
  73
  74 genMacroCode target ARGS_CHK_B_LOAD_NODE args =
  75     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
  76     let [words, lbl] = map (amodeToStix target) args
  77         temp = StIndex PtrKind stgSuB (StPrim IntNegOp [words])
  78         test = StPrim AddrGeOp [stgSpB, temp]
  79         cjmp = StCondJump ulbl test
  80         assign = StAssign PtrKind stgNode lbl
  81         join = StLabel ulbl
  82     in
  83         returnSUs (\xs -> cjmp : assign : updatePAP : join : xs)
  84
  85 genMacroCode target ARGS_CHK_B [words] =
  86     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
  87     let temp = StIndex PtrKind stgSuB (StPrim IntNegOp [amodeToStix target words])
  88         test = StPrim AddrGeOp [stgSpB, temp]
  89         cjmp = StCondJump ulbl test
  90         join = StLabel ulbl
  91     in
  92         returnSUs (\xs -> cjmp : updatePAP : join : xs)
  93
  94 \end{code}
  95
  96 The @HEAP_CHK@ macro checks to see that there are enough words
  97 available in the heap (before reaching @HpLim@).  When a heap check
  98 fails, it has to call @PerformGC@ via the @PerformGC_wrapper@.  The
  99 call wrapper saves all of our volatile registers so that we don't have to.
 100
 101 Since there are @HEAP_CHK@s buried at unfortunate places in the integer
 102 primOps, this is just a wrapper.
 103
 104 \begin{code}
 105
 106 genMacroCode target HEAP_CHK args =
 107     let [liveness,words,reenter] = map (amodeToStix target) args
 108     in
 109         doHeapCheck target liveness words reenter
 110
 111 \end{code}
 112
 113 The @STK_CHK@ macro checks for enough space on the stack between @SpA@
 114 and @SpB@.  A stack check can be complicated in the parallel world,
 115 but for the sequential case, we just need to ensure that we have
 116 enough space to continue.  Not that @_StackOverflow@ doesn't return,
 117 so we don't have to @callWrapper@ it.
 118
 119 \begin{code}
 120
 121 genMacroCode target STK_CHK [liveness, aWords, bWords, spa, spb, prim, reenter] =
 122 {- Need to check to see if we are compiling with stack checks
 123     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
 124     let words = StPrim IntNegOp
 125             [StPrim IntAddOp [amodeToStix target aWords, amodeToStix target bWords]]
 126         temp = StIndex PtrKind stgSpA words
 127         test = StPrim AddrGtOp [temp, stgSpB]
 128         cjmp = StCondJump ulbl test
 129         join = StLabel ulbl
 130     in
 131         returnSUs (\xs -> cjmp : stackOverflow : join : xs)
 132 -}
 133     returnSUs id
 134
 135 \end{code}
 136
 137 @UPD_CAF@ involves changing the info pointer of the closure, adding an indirection,
 138 and putting the new CAF on a linked list for the storage manager.
 139
 140 \begin{code}
 141
 142 genMacroCode target UPD_CAF args =
 143     let [cafptr,bhptr] = map (amodeToStix target) args
 144         w0 = StInd PtrKind cafptr
 145         w1 = StInd PtrKind (StIndex PtrKind cafptr (StInt 1))
 146         w2 = StInd PtrKind (StIndex PtrKind cafptr (StInt 2))
 147         a1 = StAssign PtrKind w0 caf_info
 148         a2 = StAssign PtrKind w1 smCAFlist
 149         a3 = StAssign PtrKind w2 bhptr
 150         a4 = StAssign PtrKind smCAFlist cafptr
 151     in
 152         returnSUs (\xs -> a1 : a2 : a3 : a4 : xs)
 153
 154 \end{code}
 155
 156 @UPD_IND@ is complicated by the fact that we are supporting the
 157 Appel-style garbage collector by default.  This means some extra work
 158 if we update an old generation object.
 159
 160 \begin{code}
 161
 162 genMacroCode target UPD_IND args =
 163     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
 164     let [updptr, heapptr] = map (amodeToStix target) args
 165         test = StPrim AddrGtOp [updptr, smOldLim]
 166         cjmp = StCondJump ulbl test
 167         updRoots = StAssign PtrKind smOldMutables updptr
 168         join = StLabel ulbl
 169         upd0 = StAssign PtrKind (StInd PtrKind updptr) ind_info
 170         upd1 = StAssign PtrKind (StInd PtrKind
 171                 (StIndex PtrKind updptr (StInt 1))) smOldMutables
 172         upd2 = StAssign PtrKind (StInd PtrKind
 173                 (StIndex PtrKind updptr (StInt 2))) heapptr
 174     in
 175         returnSUs (\xs -> cjmp : upd1 : updRoots : join : upd0 : upd2 : xs)
 176
 177 \end{code}
 178
 179 @UPD_INPLACE_NOPTRS@ is only needed for ticky-ticky profiling.
 180
 181 \begin{code}
 182
 183 genMacroCode target UPD_INPLACE_NOPTRS args = returnSUs id
 184
 185 \end{code}
 186
 187 @UPD_INPLACE_PTRS@ is complicated by the fact that we are supporting
 188 the Appel-style garbage collector by default.  This means some extra work
 189 if we update an old generation object.
 190
 191 \begin{code}
 192
 193 genMacroCode target UPD_INPLACE_PTRS [liveness] =
 194     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
 195     let cjmp = StCondJump ulbl testOldLim
 196         testOldLim = StPrim AddrGtOp [stgNode, smOldLim]
 197         join = StLabel ulbl
 198         updUpd0 = StAssign PtrKind (StInd PtrKind stgNode) ind_info
 199         updUpd1 = StAssign PtrKind (StInd PtrKind
 200                     (StIndex PtrKind stgNode (StInt 1))) smOldMutables
 201         updUpd2 = StAssign PtrKind (StInd PtrKind
 202                     (StIndex PtrKind stgNode (StInt 2))) hpBack2
 203         hpBack2 = StIndex PtrKind stgHp (StInt (-2))
 204         updOldMutables = StAssign PtrKind smOldMutables stgNode
 205         updUpdReg = StAssign PtrKind stgNode hpBack2
 206     in
 207         genMacroCode target HEAP_CHK [liveness, mkIntCLit_3, mkIntCLit_0]
 208                                                         `thenSUs` \ heap_chk ->
 209         returnSUs (\xs -> (cjmp :
 210                             heap_chk (updUpd0 : updUpd1 : updUpd2 :
 211                                         updOldMutables : updUpdReg : join : xs)))
 212
 213 \end{code}
 214
 215 @UPD_BH_UPDATABLE@ is only used when running concurrent threads (in
 216 the sequential case, the GC takes care of this).  However, we do need
 217 to handle @UPD_BH_SINGLE_ENTRY@ in all cases.
 218
 219 \begin{code}
 220
 221 genMacroCode target UPD_BH_UPDATABLE args = returnSUs id
 222
 223 genMacroCode target UPD_BH_SINGLE_ENTRY [arg] =
 224     let
 225         update = StAssign PtrKind (StInd PtrKind (amodeToStix target arg)) bh_info
 226     in
 227         returnSUs (\xs -> update : xs)
 228
 229 \end{code}
 230
 231 Push a four word update frame on the stack and slide the Su[AB]
 232 registers to the current Sp[AB] locations.
 233
 234 \begin{code}
 235
 236 genMacroCode target PUSH_STD_UPD_FRAME args =
 237     let [bhptr, aWords, bWords] = map (amodeToStix target) args
 238         frame n = StInd PtrKind
 239             (StIndex PtrKind stgSpB (StPrim IntAddOp
 240                 [bWords, StInt (toInteger (sTD_UF_SIZE - n))]))
 241
 242         a1 = StAssign PtrKind (frame uF_RET) stgRetReg
 243         a2 = StAssign PtrKind (frame uF_SUB) stgSuB
 244         a3 = StAssign PtrKind (frame uF_SUA) stgSuA
 245         a4 = StAssign PtrKind (frame uF_UPDATEE) bhptr
 246
 247         updSuB = StAssign PtrKind
 248             stgSuB (StIndex PtrKind stgSpB (StPrim IntAddOp
 249                 [bWords, StInt (toInteger sTD_UF_SIZE)]))
 250         updSuA = StAssign PtrKind
 251             stgSuA (StIndex PtrKind stgSpA (StPrim IntNegOp [aWords]))
 252     in
 253         returnSUs (\xs -> a1 : a2 : a3 : a4 : updSuB : updSuA : xs)
 254
 255 \end{code}
 256
 257 Pop a standard update frame.
 258
 259 \begin{code}
 260
 261 genMacroCode target POP_STD_UPD_FRAME args =
 262     let frame n = StInd PtrKind (StIndex PtrKind stgSpB (StInt (toInteger (-n))))
 263
 264         grabRet = StAssign PtrKind stgRetReg (frame uF_RET)
 265         grabSuB = StAssign PtrKind stgSuB    (frame uF_SUB)
 266         grabSuA = StAssign PtrKind stgSuA    (frame uF_SUA)
 267
 268         updSpB = StAssign PtrKind
 269             stgSpB (StIndex PtrKind stgSpB (StInt (toInteger (-sTD_UF_SIZE))))
 270     in
 271         returnSUs (\xs -> grabRet : grabSuB : grabSuA : updSpB : xs)
 272
 273 \end{code}
 274
 275 @PUSH_CON_UPD_FRAME@ appears to be unused at the moment.
 276
 277 \begin{code}
 278 {- UNUSED:
 279 genMacroCode target PUSH_CON_UPD_FRAME args =
 280     panic "genMacroCode:PUSH_CON_UPD_FRAME"
 281 -}
 282 \end{code}
 283
 284 The @SET_ARITY@ and @CHK_ARITY@ macros are disabled for ``normal'' compilation.
 285
 286 \begin{code}
 287
 288 genMacroCode target SET_ARITY args = returnSUs id
 289 genMacroCode target CHK_ARITY args = returnSUs id
 290
 291 \end{code}
 292
 293 This one only applies if we have a machine register devoted to TagReg.
 294
 295 \begin{code}
 296
 297 genMacroCode target SET_TAG [tag] =
 298     let set_tag = StAssign IntKind stgTagReg (amodeToStix target tag)
 299     in
 300         case stgReg target TagReg of
 301             Always _ -> returnSUs id
 302             Save _ -> returnSUs (\xs -> set_tag : xs)
 303
 304 \end{code}
 305
 306 Do the business for a @HEAP_CHK@, having converted the args to Trees
 307 of StixOp.
 308
 309 \begin{code}
 310
 311 doHeapCheck
 312     :: Target
 313     -> StixTree         -- liveness
 314     -> StixTree         -- words needed
 315     -> StixTree         -- always reenter node? (boolean)
 316     -> SUniqSM StixTreeList
 317
 318 doHeapCheck target liveness words reenter =
 319     getUniqLabelNCG                                     `thenSUs` \ ulbl ->
 320     let newHp = StIndex PtrKind stgHp words
 321         assign = StAssign PtrKind stgHp newHp
 322         test = StPrim AddrLeOp [stgHp, stgHpLim]
 323         cjmp = StCondJump ulbl test
 324         arg = StPrim IntAddOp [StPrim IntMulOp [words, StInt 256], liveness]
 325         -- ToDo: Overflow?  (JSM)
 326         gc = StCall SLIT("PerformGC_wrapper") VoidKind [arg]
 327         join = StLabel ulbl
 328     in
 329         returnSUs (\xs -> assign : cjmp : gc : join : xs)
 330
 331 \end{code}
 332
 333 Let's make sure that these CAFs are lifted out, shall we?
 334
 335 \begin{code}
 336
 337 -- Some common labels
 338
 339 bh_info, caf_info, ind_info :: StixTree
 340
 341 bh_info   = sStLitLbl SLIT("BH_SINGLE_info")
 342 caf_info  = sStLitLbl SLIT("Caf_info")
 343 ind_info  = sStLitLbl SLIT("Ind_info")
 344
 345 -- Some common call trees
 346
 347 updatePAP, stackOverflow :: StixTree
 348
 349 updatePAP     = StJump (sStLitLbl SLIT("UpdatePAP"))
 350 stackOverflow = StCall SLIT("StackOverflow") VoidKind []
 351
 352 \end{code}
 353
 354 Storage manager nonsense.  Note that the indices are dependent on
 355 the definition of the smInfo structure in SMinterface.lh
 356
 357 \begin{code}
 358
 359 #include "../../includes/platform.h"
 360
 361 #if alpha_TARGET_ARCH
 362 #include "../../includes/alpha-dec-osf1.h"
 363 #else
 364 #if sunos4_TARGET_OS
 365 #include "../../includes/sparc-sun-sunos4.h"
 366 #else
 367 #include "../../includes/sparc-sun-solaris2.h"
 368 #endif
 369 #endif
 370
 371 storageMgrInfo, smCAFlist, smOldMutables, smOldLim :: StixTree
 372
 373 storageMgrInfo = sStLitLbl SLIT("StorageMgrInfo")
 374 smCAFlist  = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_CAFLIST))
 375 smOldMutables = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDMUTABLES))
 376 smOldLim   = StInd PtrKind (StIndex PtrKind storageMgrInfo (StInt SM_OLDLIM))
 377
 378 smStablePtrTable = StInd PtrKind
 379                          (StIndex PtrKind storageMgrInfo (StInt SM_STABLEPOINTERTABLE))
 380
 381 \end{code}