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