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