ghc/compiler/nativeGen/StixMacro.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1998
   3 %
   4
   5 \begin{code}
   6 module StixMacro ( macroCode, checkCode ) where
   7
   8 #include "HsVersions.h"
   9 #include "nativeGen/NCG.h"
  10
  11 import {-# SOURCE #-} StixPrim ( amodeToStix )
  12
  13 import MachMisc
  14 import MachRegs
  15 import AbsCSyn          ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
  16                           CCheckMacro(..) )
  17 import Constants        ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE )
  18 import CallConv         ( cCallConv )
  19 import OrdList          ( OrdList )
  20 import PrimOp           ( PrimOp(..) )
  21 import PrimRep          ( PrimRep(..) )
  22 import Stix
  23 import UniqSupply       ( returnUs, thenUs, UniqSM )
  24 import Outputable
  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 macroCode
  34     :: CStmtMacro           -- statement macro
  35     -> [CAddrMode]          -- args
  36     -> UniqSM StixTreeList
  37 \end{code}
  38
  39 -----------------------------------------------------------------------------
  40 Argument satisfaction checks.
  41
  42 \begin{code}
  43 macroCode ARGS_CHK_LOAD_NODE args
  44   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  45     let
  46           [words, lbl] = map amodeToStix args
  47           temp = StIndex PtrRep stgSp words
  48           test = StPrim AddrGeOp [stgSu, temp]
  49           cjmp = StCondJump ulbl test
  50           assign = StAssign PtrRep stgNode lbl
  51           join = StLabel ulbl
  52     in
  53     returnUs (\xs -> cjmp : assign : updatePAP : join : xs)
  54
  55 macroCode ARGS_CHK [words]
  56   = getUniqLabelNCG                                     `thenUs` \ ulbl ->
  57     let temp = StIndex PtrRep stgSp (amodeToStix words)
  58         test = StPrim AddrGeOp [stgSu, temp]
  59         cjmp = StCondJump ulbl test
  60         join = StLabel ulbl
  61     in
  62     returnUs (\xs -> cjmp : updatePAP : join : xs)
  63 \end{code}
  64
  65 -----------------------------------------------------------------------------
  66 Updating a CAF
  67
  68 @UPD_CAF@ involves changing the info pointer of the closure, and
  69 adding an indirection.
  70
  71 \begin{code}
  72 macroCode UPD_CAF args
  73   = let
  74         [cafptr,bhptr] = map amodeToStix args
  75         w0 = StInd PtrRep cafptr
  76         w1 = StInd PtrRep (StIndex PtrRep cafptr fixedHS)
  77         blocking_queue = StInd PtrRep (StIndex PtrRep bhptr fixedHS)
  78         a1 = StAssign PtrRep w0 ind_static_info
  79         a2 = StAssign PtrRep w1 bhptr
  80         a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
  81     in
  82     returnUs (\xs -> a1 : a2 : a3 : xs)
  83 \end{code}
  84
  85 -----------------------------------------------------------------------------
  86 Blackholing
  87
  88 We do lazy blackholing: no need to overwrite thunks with blackholes
  89 the minute they're entered, as long as we do it before a context
  90 switch or garbage collection, that's ok.
  91
  92 Don't blackhole single entry closures, for the following reasons:
  93
  94         - if the compiler has decided that they won't be entered again,
  95           that probably means that nothing has a pointer to it
  96           (not necessarily true, but...)
  97
  98         - no need to blackhole for concurrency reasons, because nothing
  99           can block on the result of this computation.
 100
 101 \begin{code}
 102 macroCode UPD_BH_UPDATABLE args = returnUs id
 103
 104 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
 105 {-
 106   = let
 107         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
 108     in
 109     returnUs (\xs -> update : xs)
 110 -}
 111 \end{code}
 112
 113 -----------------------------------------------------------------------------
 114 Update frames
 115
 116 Push a four word update frame on the stack and slide the Su registers
 117 to the current Sp location.
 118
 119 \begin{code}
 120 macroCode PUSH_UPD_FRAME args
 121   = let
 122         [bhptr, _{-0-}] = map amodeToStix args
 123         frame n = StInd PtrRep
 124             (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
 125
 126         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
 127         a1 = StAssign PtrRep (frame uF_RET)     upd_frame_info
 128         a3 = StAssign PtrRep (frame uF_SU)      stgSu
 129         a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
 130
 131         updSu = StAssign PtrRep stgSu
 132                 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
 133     in
 134     returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
 135
 136
 137 macroCode PUSH_SEQ_FRAME args
 138    = let [arg_frame] = map amodeToStix args
 139          frame n = StInd PtrRep
 140                      (StIndex PtrRep arg_frame (StInt (toInteger n)))
 141          a1 = StAssign PtrRep (frame 0) seq_frame_info
 142          a2 = StAssign PtrRep (frame 1) stgSu
 143          updSu = StAssign PtrRep stgSu arg_frame
 144      in
 145      returnUs (\xs -> a1 : a2 : updSu : xs)
 146
 147
 148 macroCode UPDATE_SU_FROM_UPD_FRAME args
 149    = let [arg_frame] = map amodeToStix args
 150          frame n = StInd PtrRep
 151                       (StIndex PtrRep arg_frame (StInt (toInteger n)))
 152          updSu
 153             = StAssign PtrRep stgSu (frame uF_SU)
 154      in
 155      returnUs (\xs -> updSu : xs)
 156 \end{code}
 157
 158 -----------------------------------------------------------------------------
 159 Setting the tag register
 160
 161 This one only applies if we have a machine register devoted to TagReg.
 162
 163 \begin{code}
 164 macroCode SET_TAG [tag]
 165   = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
 166     in
 167     case stgReg tagreg of
 168       Always _ -> returnUs id
 169       Save   _ -> returnUs (\ xs -> set_tag : xs)
 170
 171 macroCode other args
 172    = case other of
 173         ARGS_CHK -> error "foobarxyzzy1"
 174         ARGS_CHK_LOAD_NODE -> error "foobarxyzzy2"
 175         UPD_CAF -> error "foobarxyzzy3"
 176         UPD_BH_UPDATABLE -> error "foobarxyzzy4"
 177         UPD_BH_SINGLE_ENTRY -> error "foobarxyzzy5"
 178         PUSH_UPD_FRAME -> error "foobarxyzzy6"
 179         PUSH_SEQ_FRAME -> error "foobarxyzzy7"
 180         UPDATE_SU_FROM_UPD_FRAME -> error "foobarxyzzy8"
 181         SET_TAG -> error "foobarxyzzy9"
 182
 183 \end{code}
 184
 185
 186 Do the business for a @HEAP_CHK@, having converted the args to Trees
 187 of StixOp.
 188
 189 -----------------------------------------------------------------------------
 190 Let's make sure that these CAFs are lifted out, shall we?
 191
 192 \begin{code}
 193 -- Some common labels
 194
 195 bh_info, ind_static_info, ind_info :: StixTree
 196
 197 bh_info         = sStLitLbl SLIT("BLACKHOLE_info")
 198 ind_static_info = sStLitLbl SLIT("IND_STATIC_info")
 199 ind_info        = sStLitLbl SLIT("IND_info")
 200 upd_frame_info  = sStLitLbl SLIT("Upd_frame_info")
 201 seq_frame_info  = sStLitLbl SLIT("seq_frame_info")
 202
 203 -- Some common call trees
 204
 205 updatePAP, stackOverflow :: StixTree
 206
 207 updatePAP     = StJump (sStLitLbl SLIT("stg_update_PAP"))
 208 stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
 209 \end{code}
 210
 211 -----------------------------------------------------------------------------
 212 Heap/Stack checks
 213
 214 \begin{code}
 215 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
 216 checkCode macro args assts
 217   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 218     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 219
 220     let args_stix = map amodeToStix args
 221         newHp wds = StIndex PtrRep stgHp wds
 222         assign_hp wds = StAssign PtrRep stgHp (newHp wds)
 223         test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
 224         cjmp_hp = StCondJump ulbl_pass test_hp
 225
 226         newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
 227         test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
 228         test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
 229         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 230         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 231
 232         assign_ret r ret = StAssign CodePtrRep r ret
 233
 234         fail = StLabel ulbl_fail
 235         join = StLabel ulbl_pass
 236
 237         -- see includes/StgMacros.h for explaination of these magic consts
 238         aLL_NON_PTRS
 239            = IF_ARCH_alpha(16383,65535)
 240
 241         assign_liveness ptr_regs
 242            = StAssign WordRep stgR9
 243                       (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
 244         assign_reentry reentry
 245            = StAssign WordRep stgR10 reentry
 246     in
 247
 248     returnUs (
 249     case macro of
 250         HP_CHK_NP      ->
 251                 let [words,ptrs] = args_stix
 252                 in  (\xs -> assign_hp words : cjmp_hp :
 253                             assts (gc_enter ptrs : join : xs))
 254
 255         STK_CHK_NP     ->
 256                 let [words,ptrs] = args_stix
 257                 in  (\xs -> cjmp_sp_pass words :
 258                             assts (gc_enter ptrs : join : xs))
 259
 260         HP_STK_CHK_NP  ->
 261                 let [sp_words,hp_words,ptrs] = args_stix
 262                 in  (\xs -> cjmp_sp_fail sp_words :
 263                             assign_hp hp_words : cjmp_hp :
 264                             fail :
 265                             assts (gc_enter ptrs : join : xs))
 266
 267         HP_CHK         ->
 268                 let [words,ret,r,ptrs] = args_stix
 269                 in  (\xs -> assign_hp words : cjmp_hp :
 270                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 271
 272         STK_CHK        ->
 273                 let [words,ret,r,ptrs] = args_stix
 274                 in  (\xs -> cjmp_sp_pass words :
 275                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 276
 277         HP_STK_CHK     ->
 278                 let [sp_words,hp_words,ret,r,ptrs] = args_stix
 279                 in  (\xs -> cjmp_sp_fail sp_words :
 280                             assign_hp hp_words : cjmp_hp :
 281                             fail :
 282                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 283
 284         HP_CHK_NOREGS  ->
 285                 let [words] = args_stix
 286                 in  (\xs -> assign_hp words : cjmp_hp :
 287                             assts (gc_noregs : join : xs))
 288
 289         HP_CHK_UNPT_R1 ->
 290                 let [words] = args_stix
 291                 in  (\xs -> assign_hp words : cjmp_hp :
 292                             assts (gc_unpt_r1 : join : xs))
 293
 294         HP_CHK_UNBX_R1 ->
 295                 let [words] = args_stix
 296                 in  (\xs -> assign_hp words : cjmp_hp :
 297                             assts (gc_unbx_r1 : join : xs))
 298
 299         HP_CHK_F1      ->
 300                 let [words] = args_stix
 301                 in  (\xs -> assign_hp words : cjmp_hp :
 302                             assts (gc_f1 : join : xs))
 303
 304         HP_CHK_D1      ->
 305                 let [words] = args_stix
 306                 in  (\xs -> assign_hp words : cjmp_hp :
 307                             assts (gc_d1 : join : xs))
 308
 309         HP_CHK_UT_ALT  ->
 310                 let [words,ptrs,nonptrs,r,ret] = args_stix
 311                 in (\xs -> assign_hp words : cjmp_hp :
 312                            assts (assign_ret r ret : gc_ut ptrs nonptrs : join : xs))
 313
 314         HP_CHK_GEN     ->
 315                 let [words,liveness,reentry] = args_stix
 316                 in (\xs -> assign_hp words : cjmp_hp :
 317                            assts (assign_liveness liveness :
 318                                   assign_reentry reentry :
 319                                   gc_gen : join : xs))
 320     )
 321
 322 -- Various canned heap-check routines
 323
 324 gc_chk (StInt n)   = StJump (StLitLbl (ptext SLIT("stg_chk_") <> int (fromInteger n)))
 325 gc_enter (StInt n) = StJump (StLitLbl (ptext SLIT("stg_gc_enter_") <> int (fromInteger n)))
 326 gc_noregs          = StJump (StLitLbl (ptext SLIT("stg_gc_noregs")))
 327 gc_unpt_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unpt_r1")))
 328 gc_unbx_r1         = StJump (StLitLbl (ptext SLIT("stg_gc_unbx_r1")))
 329 gc_f1              = StJump (StLitLbl (ptext SLIT("stg_gc_f1")))
 330 gc_d1              = StJump (StLitLbl (ptext SLIT("stg_gc_d1")))
 331 gc_gen             = StJump (StLitLbl (ptext SLIT("stg_gen_chk")))
 332
 333 gc_ut (StInt p) (StInt np)
 334                    = StJump (StLitLbl (ptext SLIT("stg_gc_ut_") <> int (fromInteger p)
 335                                        <> char '_' <> int (fromInteger np)))
 336 \end{code}