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(..), CAddrMode, tagreg, CCheckMacro(..) )
  15 import Constants        ( uF_RET, uF_UPDATEE, uF_SIZE )
  16 import ForeignCall      ( CCallConv(..) )
  17 import MachOp           ( MachOp(..) )
  18 import PrimRep          ( PrimRep(..) )
  19 import Stix
  20 import Panic            ( panic )
  21 import UniqSupply       ( returnUs, thenUs, UniqSM )
  22 import CLabel           ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
  23                           mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
  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 macroCode
  33     :: CStmtMacro           -- statement macro
  34     -> [CAddrMode]          -- args
  35     -> UniqSM StixStmtList
  36 \end{code}
  37
  38 -----------------------------------------------------------------------------
  39 Updating a CAF
  40
  41 @UPD_CAF@ involves changing the info pointer of the closure, and
  42 adding an indirection.
  43
  44 \begin{code}
  45 macroCode UPD_CAF args
  46   = let
  47         [cafptr,bhptr] = map amodeToStix args
  48         new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
  49         a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
  50         a2 = StAssignMem PtrRep cafptr ind_static_info
  51     in
  52     returnUs (\xs -> new_caf : a1 : a2 : xs)
  53 \end{code}
  54
  55 -----------------------------------------------------------------------------
  56 Blackholing
  57
  58 We do lazy blackholing: no need to overwrite thunks with blackholes
  59 the minute they're entered, as long as we do it before a context
  60 switch or garbage collection, that's ok.
  61
  62 Don't blackhole single entry closures, for the following reasons:
  63
  64         - if the compiler has decided that they won't be entered again,
  65           that probably means that nothing has a pointer to it
  66           (not necessarily true, but...)
  67
  68         - no need to blackhole for concurrency reasons, because nothing
  69           can block on the result of this computation.
  70
  71 \begin{code}
  72 macroCode UPD_BH_UPDATABLE args = returnUs id
  73
  74 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
  75 {-
  76   = let
  77         update = StAssign PtrRep (StInd PtrRep (amodeToStix arg)) bh_info
  78     in
  79     returnUs (\xs -> update : xs)
  80 -}
  81 \end{code}
  82
  83 -----------------------------------------------------------------------------
  84 Update frames
  85
  86 Push an update frame on the stack.
  87
  88 \begin{code}
  89 macroCode PUSH_UPD_FRAME args
  90   = let
  91         [bhptr, _{-0-}] = map amodeToStix args
  92         frame n = StIndex PtrRep (StReg stgSp) (StInt (toInteger (n-uF_SIZE)))
  93
  94         -- HWL: these values are *wrong* in a GranSim setup; ToDo: fix
  95         a1 = StAssignMem PtrRep (frame uF_RET)     upd_frame_info
  96         a4 = StAssignMem PtrRep (frame uF_UPDATEE) bhptr
  97     in
  98     returnUs (\xs -> a1 : a4 : xs)
  99 \end{code}
 100
 101 -----------------------------------------------------------------------------
 102 Setting the tag register
 103
 104 This one only applies if we have a machine register devoted to TagReg.
 105
 106 \begin{code}
 107 macroCode SET_TAG [tag]
 108   = case get_MagicId_reg_or_addr tagreg of
 109        Right baseRegAddr
 110           -> returnUs id
 111        Left  realreg
 112           -> let a1 = StAssignReg IntRep (StixMagicId tagreg) (amodeToStix tag)
 113              in returnUs ( \xs -> a1 : xs )
 114 \end{code}
 115
 116 -----------------------------------------------------------------------------
 117
 118 \begin{code}
 119 macroCode REGISTER_IMPORT [arg]
 120    = returnUs (
 121         \xs -> StAssignMem WordRep (StReg stgSp) (amodeToStix arg)
 122              : StAssignReg PtrRep  stgSp (StMachOp MO_Nat_Add [StReg stgSp, StInt 4])
 123              : xs
 124      )
 125
 126 macroCode REGISTER_FOREIGN_EXPORT [arg]
 127    = returnUs (
 128         \xs -> StVoidable (
 129                   StCall (Left FSLIT("getStablePtr")) CCallConv VoidRep
 130                          [amodeToStix arg]
 131                )
 132              : xs
 133      )
 134
 135 macroCode other args
 136    = panic "StixMacro.macroCode"
 137 \end{code}
 138
 139 Do the business for a @HEAP_CHK@, having converted the args to Trees
 140 of StixOp.
 141
 142 -----------------------------------------------------------------------------
 143 Let's make sure that these CAFs are lifted out, shall we?
 144
 145 \begin{code}
 146 -- Some common labels
 147
 148 bh_info, ind_static_info, ind_info :: StixExpr
 149
 150 bh_info         = StCLbl mkBlackHoleInfoTableLabel
 151 ind_static_info = StCLbl mkIndStaticInfoLabel
 152 ind_info        = StCLbl mkIndInfoLabel
 153 upd_frame_info  = StCLbl mkUpdInfoLabel
 154
 155 -- Some common call trees
 156 \end{code}
 157
 158 -----------------------------------------------------------------------------
 159 Heap/Stack checks
 160
 161 \begin{code}
 162 checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
 163 checkCode macro args assts
 164   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 165     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 166
 167     let args_stix        = map amodeToStix args
 168         newHp wds        = StIndex PtrRep (StReg stgHp) wds
 169         assign_hp wds    = StAssignReg PtrRep stgHp (newHp wds)
 170         hp_alloc wds     = StAssignReg IntRep stgHpAlloc wds
 171         test_hp          = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
 172         cjmp_hp          = StCondJump ulbl_pass test_hp
 173         newSp wds        = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
 174         test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
 175         test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
 176         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 177         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 178         assign_ret r ret = mkStAssign CodePtrRep r ret
 179
 180         fail = StLabel ulbl_fail
 181         join = StLabel ulbl_pass
 182
 183         -- see includes/StgMacros.h for explaination of these magic consts
 184         aLL_NON_PTRS
 185            = IF_ARCH_alpha(16383,65535)
 186
 187         assign_liveness ptr_regs
 188            = StAssignReg WordRep stgR9
 189                          (StMachOp MO_Nat_Xor [StInt aLL_NON_PTRS, ptr_regs])
 190         assign_reentry reentry
 191            = StAssignReg WordRep stgR10 reentry
 192     in
 193
 194     returnUs (
 195     case macro of
 196         HP_CHK_NP      ->
 197                 let [words] = args_stix
 198                 in  (\xs -> assign_hp words : cjmp_hp :
 199                             assts (hp_alloc words : gc_enter : join : xs))
 200
 201         STK_CHK_NP     ->
 202                 let [words] = args_stix
 203                 in  (\xs -> cjmp_sp_pass words :
 204                             assts (gc_enter : join : xs))
 205
 206         HP_STK_CHK_NP  ->
 207                 let [sp_words,hp_words] = args_stix
 208                 in  (\xs -> cjmp_sp_fail sp_words :
 209                             assign_hp hp_words : cjmp_hp :
 210                             fail :
 211                             assts (hp_alloc hp_words : gc_enter
 212                                    : join : xs))
 213
 214         HP_CHK_FUN       ->
 215                 let [words] = args_stix
 216                 in  (\xs -> assign_hp words : cjmp_hp :
 217                             assts (hp_alloc words : gc_fun : join : xs))
 218
 219         STK_CHK_FUN       ->
 220                 let [words] = args_stix
 221                 in  (\xs -> cjmp_sp_pass words :
 222                             assts (gc_fun : join : xs))
 223
 224         HP_STK_CHK_FUN    ->
 225                 let [sp_words,hp_words] = args_stix
 226                 in  (\xs -> cjmp_sp_fail sp_words :
 227                             assign_hp hp_words : cjmp_hp :
 228                             fail :
 229                             assts (hp_alloc hp_words
 230                                   : gc_fun : join : xs))
 231
 232         HP_CHK_NOREGS  ->
 233                 let [words] = args_stix
 234                 in  (\xs -> assign_hp words : cjmp_hp :
 235                             assts (hp_alloc words : gc_noregs : join : xs))
 236
 237         HP_CHK_UNPT_R1 ->
 238                 let [words] = args_stix
 239                 in  (\xs -> assign_hp words : cjmp_hp :
 240                             assts (hp_alloc words : gc_unpt_r1 : join : xs))
 241
 242         HP_CHK_UNBX_R1 ->
 243                 let [words] = args_stix
 244                 in  (\xs -> assign_hp words : cjmp_hp :
 245                             assts (hp_alloc words : gc_unbx_r1 : join : xs))
 246
 247         HP_CHK_F1      ->
 248                 let [words] = args_stix
 249                 in  (\xs -> assign_hp words : cjmp_hp :
 250                             assts (hp_alloc words : gc_f1 : join : xs))
 251
 252         HP_CHK_D1      ->
 253                 let [words] = args_stix
 254                 in  (\xs -> assign_hp words : cjmp_hp :
 255                             assts (hp_alloc words : gc_d1 : join : xs))
 256
 257         HP_CHK_L1      ->
 258                 let [words] = args_stix
 259                 in  (\xs -> assign_hp words : cjmp_hp :
 260                             assts (hp_alloc words : gc_l1 : join : xs))
 261
 262         HP_CHK_UNBX_TUPLE  ->
 263                 let [words,liveness] = args_stix
 264                 in (\xs -> assign_hp words : cjmp_hp :
 265                            assts (hp_alloc words : assign_liveness liveness :
 266                                   gc_ut : join : xs))
 267     )
 268
 269 -- Various canned heap-check routines
 270
 271 mkStJump_to_GCentry_name :: String -> StixStmt
 272 mkStJump_to_GCentry_name gcname
 273 --   | opt_Static
 274    = StJump NoDestInfo (StCLbl (mkRtsGCEntryLabel gcname))
 275 --   | otherwise -- it's in a different DLL
 276 --   = StJump (StInd PtrRep (StLitLbl True sdoc))
 277
 278 mkStJump_to_RegTable_offw :: Int -> StixStmt
 279 mkStJump_to_RegTable_offw regtable_offw
 280 --   | opt_Static
 281    = StJump NoDestInfo (StInd PtrRep (get_Regtable_addr_from_offset regtable_offw))
 282 --   | otherwise
 283 --   do something plausible for cross-DLL jump
 284
 285 gc_enter = mkStJump_to_RegTable_offw OFFSET_stgGCEnter1
 286 gc_fun   = mkStJump_to_RegTable_offw OFFSET_stgGCFun
 287
 288 gc_noregs          = mkStJump_to_GCentry_name "stg_gc_noregs"
 289 gc_unpt_r1         = mkStJump_to_GCentry_name "stg_gc_unpt_r1"
 290 gc_unbx_r1         = mkStJump_to_GCentry_name "stg_gc_unbx_r1"
 291 gc_f1              = mkStJump_to_GCentry_name "stg_gc_f1"
 292 gc_d1              = mkStJump_to_GCentry_name "stg_gc_d1"
 293 gc_l1              = mkStJump_to_GCentry_name "stg_gc_l1"
 294 gc_ut              = mkStJump_to_GCentry_name "stg_gc_ut"
 295 \end{code}