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 MachRegs
  14 import AbsCSyn          ( CStmtMacro(..), MagicId(..), CAddrMode, tagreg,
  15                           CCheckMacro(..) )
  16 import Constants        ( uF_RET, uF_SU, uF_UPDATEE, uF_SIZE, sEQ_FRAME_SIZE )
  17 import CallConv         ( cCallConv )
  18 import PrimOp           ( PrimOp(..) )
  19 import PrimRep          ( PrimRep(..) )
  20 import Stix
  21 import UniqSupply       ( returnUs, thenUs, UniqSM )
  22 import CLabel           ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
  23                           mkIndInfoLabel, mkUpdInfoLabel, mkSeqInfoLabel,
  24                           mkRtsGCEntryLabel, mkStgUpdatePAPLabel )
  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         a1 = StAssign PtrRep w0 ind_static_info
  78         a2 = StAssign PtrRep w1 bhptr
  79         a3 = StCall SLIT("newCAF") cCallConv VoidRep [cafptr]
  80     in
  81     returnUs (\xs -> a1 : a2 : a3 : xs)
  82 \end{code}
  83
  84 -----------------------------------------------------------------------------
  85 Blackholing
  86
  87 We do lazy blackholing: no need to overwrite thunks with blackholes
  88 the minute they're entered, as long as we do it before a context
  89 switch or garbage collection, that's ok.
  90
  91 Don't blackhole single entry closures, for the following reasons:
  92
  93         - if the compiler has decided that they won't be entered again,
  94           that probably means that nothing has a pointer to it
  95           (not necessarily true, but...)
  96
  97         - no need to blackhole for concurrency reasons, because nothing
  98           can block on the result of this computation.
  99
 100 \begin{code}
 101 macroCode UPD_BH_UPDATABLE args = returnUs id
 102
 103 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
 104 {-
 105   = let
 106         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
 107     in
 108     returnUs (\xs -> update : xs)
 109 -}
 110 \end{code}
 111
 112 -----------------------------------------------------------------------------
 113 Update frames
 114
 115 Push a four word update frame on the stack and slide the Su registers
 116 to the current Sp location.
 117
 118 \begin{code}
 119 macroCode PUSH_UPD_FRAME args
 120   = let
 121         [bhptr, _{-0-}] = map amodeToStix args
 122         frame n = StInd PtrRep
 123             (StIndex PtrRep stgSp (StInt (toInteger (n-uF_SIZE))))
 124
 125         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
 126         a1 = StAssign PtrRep (frame uF_RET)     upd_frame_info
 127         a3 = StAssign PtrRep (frame uF_SU)      stgSu
 128         a4 = StAssign PtrRep (frame uF_UPDATEE) bhptr
 129
 130         updSu = StAssign PtrRep stgSu
 131                 (StIndex PtrRep stgSp (StInt (toInteger (-uF_SIZE))))
 132     in
 133     returnUs (\xs -> a1 : a3 : a4 : updSu : xs)
 134
 135
 136 macroCode PUSH_SEQ_FRAME args
 137    = let [arg_frame] = map amodeToStix args
 138          frame n = StInd PtrRep
 139                      (StIndex PtrRep arg_frame (StInt (toInteger n)))
 140          a1 = StAssign PtrRep (frame 0) seq_frame_info
 141          a2 = StAssign PtrRep (frame 1) stgSu
 142          updSu = StAssign PtrRep stgSu arg_frame
 143      in
 144      returnUs (\xs -> a1 : a2 : updSu : xs)
 145
 146
 147 macroCode UPDATE_SU_FROM_UPD_FRAME args
 148    = let [arg_frame] = map amodeToStix args
 149          frame n = StInd PtrRep
 150                       (StIndex PtrRep arg_frame (StInt (toInteger n)))
 151          updSu
 152             = StAssign PtrRep stgSu (frame uF_SU)
 153      in
 154      returnUs (\xs -> updSu : xs)
 155 \end{code}
 156
 157 -----------------------------------------------------------------------------
 158 Setting the tag register
 159
 160 This one only applies if we have a machine register devoted to TagReg.
 161
 162 \begin{code}
 163 macroCode SET_TAG [tag]
 164   = let set_tag = StAssign IntRep stgTagReg (amodeToStix tag)
 165     in
 166     case stgReg tagreg of
 167       Always _ -> returnUs id
 168       Save   _ -> returnUs (\ xs -> set_tag : xs)
 169 \end{code}
 170
 171 -----------------------------------------------------------------------------
 172
 173 \begin{code}
 174 macroCode REGISTER_IMPORT [arg]
 175    = returnUs (
 176         \xs -> StAssign WordRep (StInd WordRep stgSp) (amodeToStix arg)
 177              : StAssign PtrRep  stgSp (StPrim IntAddOp [stgSp, StInt 4])
 178              : xs
 179      )
 180
 181 macroCode REGISTER_FOREIGN_EXPORT [arg]
 182    = returnUs (
 183         \xs -> StCall SLIT("getStablePtr") cCallConv VoidRep [amodeToStix arg]
 184              : xs
 185      )
 186
 187 macroCode other args
 188    = case other of
 189         SET_TAG -> error "foobarxyzzy8"
 190         _       -> error "StixMacro.macroCode: unknown macro/args"
 191 \end{code}
 192
 193
 194 Do the business for a @HEAP_CHK@, having converted the args to Trees
 195 of StixOp.
 196
 197 -----------------------------------------------------------------------------
 198 Let's make sure that these CAFs are lifted out, shall we?
 199
 200 \begin{code}
 201 -- Some common labels
 202
 203 bh_info, ind_static_info, ind_info :: StixTree
 204
 205 bh_info         = StCLbl mkBlackHoleInfoTableLabel
 206 ind_static_info = StCLbl mkIndStaticInfoLabel
 207 ind_info        = StCLbl mkIndInfoLabel
 208 upd_frame_info  = StCLbl mkUpdInfoLabel
 209 seq_frame_info  = StCLbl mkSeqInfoLabel
 210 stg_update_PAP  = StCLbl mkStgUpdatePAPLabel
 211 -- Some common call trees
 212
 213 updatePAP, stackOverflow :: StixTree
 214
 215 updatePAP     = StJump NoDestInfo stg_update_PAP
 216 stackOverflow = StCall SLIT("StackOverflow") cCallConv VoidRep []
 217 \end{code}
 218
 219 -----------------------------------------------------------------------------
 220 Heap/Stack checks
 221
 222 \begin{code}
 223 checkCode :: CCheckMacro -> [CAddrMode] -> StixTreeList -> UniqSM StixTreeList
 224 checkCode macro args assts
 225   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 226     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 227
 228     let args_stix = map amodeToStix args
 229         newHp wds = StIndex PtrRep stgHp wds
 230         assign_hp wds = StAssign PtrRep stgHp (newHp wds)
 231         test_hp = StPrim AddrLeOp [stgHp, stgHpLim]
 232         cjmp_hp = StCondJump ulbl_pass test_hp
 233
 234         newSp wds = StIndex PtrRep stgSp (StPrim IntNegOp [wds])
 235         test_sp_pass wds = StPrim AddrGeOp [newSp wds, stgSpLim]
 236         test_sp_fail wds = StPrim AddrLtOp [newSp wds, stgSpLim]
 237         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 238         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 239
 240         assign_ret r ret = StAssign CodePtrRep r ret
 241
 242         fail = StLabel ulbl_fail
 243         join = StLabel ulbl_pass
 244
 245         -- see includes/StgMacros.h for explaination of these magic consts
 246         aLL_NON_PTRS
 247            = IF_ARCH_alpha(16383,65535)
 248
 249         assign_liveness ptr_regs
 250            = StAssign WordRep stgR9
 251                       (StPrim XorOp [StInt aLL_NON_PTRS, ptr_regs])
 252         assign_reentry reentry
 253            = StAssign WordRep stgR10 reentry
 254     in
 255
 256     returnUs (
 257     case macro of
 258         HP_CHK_NP      ->
 259                 let [words,ptrs] = args_stix
 260                 in  (\xs -> assign_hp words : cjmp_hp :
 261                             assts (gc_enter ptrs : join : xs))
 262
 263         HP_CHK_SEQ_NP  ->
 264                 let [words,ptrs] = args_stix
 265                 in  (\xs -> assign_hp words : cjmp_hp :
 266                             assts (gc_seq ptrs : join : xs))
 267
 268         STK_CHK_NP     ->
 269                 let [words,ptrs] = args_stix
 270                 in  (\xs -> cjmp_sp_pass words :
 271                             assts (gc_enter ptrs : join : xs))
 272
 273         HP_STK_CHK_NP  ->
 274                 let [sp_words,hp_words,ptrs] = args_stix
 275                 in  (\xs -> cjmp_sp_fail sp_words :
 276                             assign_hp hp_words : cjmp_hp :
 277                             fail :
 278                             assts (gc_enter ptrs : join : xs))
 279
 280         HP_CHK         ->
 281                 let [words,ret,r,ptrs] = args_stix
 282                 in  (\xs -> assign_hp words : cjmp_hp :
 283                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 284
 285         STK_CHK        ->
 286                 let [words,ret,r,ptrs] = args_stix
 287                 in  (\xs -> cjmp_sp_pass words :
 288                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 289
 290         HP_STK_CHK     ->
 291                 let [sp_words,hp_words,ret,r,ptrs] = args_stix
 292                 in  (\xs -> cjmp_sp_fail sp_words :
 293                             assign_hp hp_words : cjmp_hp :
 294                             fail :
 295                             assts (assign_ret r ret : gc_chk ptrs : join : xs))
 296
 297         HP_CHK_NOREGS  ->
 298                 let [words] = args_stix
 299                 in  (\xs -> assign_hp words : cjmp_hp :
 300                             assts (gc_noregs : join : xs))
 301
 302         HP_CHK_UNPT_R1 ->
 303                 let [words] = args_stix
 304                 in  (\xs -> assign_hp words : cjmp_hp :
 305                             assts (gc_unpt_r1 : join : xs))
 306
 307         HP_CHK_UNBX_R1 ->
 308                 let [words] = args_stix
 309                 in  (\xs -> assign_hp words : cjmp_hp :
 310                             assts (gc_unbx_r1 : join : xs))
 311
 312         HP_CHK_F1      ->
 313                 let [words] = args_stix
 314                 in  (\xs -> assign_hp words : cjmp_hp :
 315                             assts (gc_f1 : join : xs))
 316
 317         HP_CHK_D1      ->
 318                 let [words] = args_stix
 319                 in  (\xs -> assign_hp words : cjmp_hp :
 320                             assts (gc_d1 : join : xs))
 321
 322         HP_CHK_UT_ALT  ->
 323                 let [words,ptrs,nonptrs,r,ret] = args_stix
 324                 in (\xs -> assign_hp words : cjmp_hp :
 325                            assts (assign_ret r ret : gc_ut ptrs nonptrs
 326                                   : join : xs))
 327
 328         HP_CHK_GEN     ->
 329                 let [words,liveness,reentry] = args_stix
 330                 in (\xs -> assign_hp words : cjmp_hp :
 331                            assts (assign_liveness liveness :
 332                                   assign_reentry reentry :
 333                                   gc_gen : join : xs))
 334     )
 335
 336 -- Various canned heap-check routines
 337
 338 mkStJump_to_GCentry :: String -> StixTree
 339 mkStJump_to_GCentry gcname
 340 --   | opt_Static
 341    = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
 342 --   | otherwise -- it's in a different DLL
 343 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
 344
 345 gc_chk (StInt n)   = mkStJump_to_GCentry ("stg_chk_" ++ show n)
 346 gc_enter (StInt n) = mkStJump_to_GCentry ("stg_gc_enter_" ++ show n)
 347 gc_seq (StInt n)   = mkStJump_to_GCentry ("stg_gc_seq_" ++ show n)
 348 gc_noregs          = mkStJump_to_GCentry "stg_gc_noregs"
 349 gc_unpt_r1         = mkStJump_to_GCentry "stg_gc_unpt_r1"
 350 gc_unbx_r1         = mkStJump_to_GCentry "stg_gc_unbx_r1"
 351 gc_f1              = mkStJump_to_GCentry "stg_gc_f1"
 352 gc_d1              = mkStJump_to_GCentry "stg_gc_d1"
 353 gc_gen             = mkStJump_to_GCentry "stg_gen_chk"
 354 gc_ut (StInt p) (StInt np)
 355                    = mkStJump_to_GCentry ("stg_gc_ut_" ++ show p
 356                                           ++ "_" ++ show np)
 357 \end{code}