ghc/compiler/nativeGen/StixMacro.lhs

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