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 SMRep            ( fixedHdrSize )
  16 import Constants        ( uF_RET, uF_UPDATEE, uF_SIZE )
  17 import ForeignCall      ( CCallConv(..) )
  18 import MachOp           ( MachOp(..) )
  19 import PrimRep          ( PrimRep(..) )
  20 import Stix
  21 import Panic            ( panic )
  22 import UniqSupply       ( returnUs, thenUs, UniqSM )
  23 import CLabel           ( mkBlackHoleInfoTableLabel, mkIndStaticInfoLabel,
  24                           mkBlackHoleBQInfoTableLabel,
  25                           mkIndInfoLabel, mkUpdInfoLabel, mkRtsGCEntryLabel )
  26 \end{code}
  27 --------------------------------------------------------------------------------
  28 The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on
  29 the A stack, and perform a tail call to @UpdatePAP@ if the arguments are
  30 not there.  The @_LOAD_NODE@ version also loads R1 with an appropriate
  31 closure address.
  32
  33 \begin{code}
  34 macroCode
  35     :: CStmtMacro           -- statement macro
  36     -> [StixExpr]           -- args
  37     -> UniqSM StixStmtList
  38 \end{code}
  39
  40 -----------------------------------------------------------------------------
  41 Updating a CAF
  42
  43 @UPD_CAF@ involves changing the info pointer of the closure, and
  44 adding an indirection.
  45
  46 \begin{code}
  47 macroCode UPD_CAF [cafptr,bhptr]
  48   = let
  49         new_caf = StVoidable (StCall (Left FSLIT("newCAF")) CCallConv VoidRep [cafptr])
  50         a1 = StAssignMem PtrRep (StIndex PtrRep cafptr fixedHS) bhptr
  51         a2 = StAssignMem PtrRep cafptr ind_static_info
  52     in
  53     returnUs (\xs -> new_caf : a1 : a2 : xs)
  54 \end{code}
  55
  56 -----------------------------------------------------------------------------
  57 Blackholing
  58
  59 We do lazy blackholing: no need to overwrite thunks with blackholes
  60 the minute they're entered, as long as we do it before a context
  61 switch or garbage collection, that's ok.
  62
  63 Don't blackhole single entry closures, for the following reasons:
  64
  65         - if the compiler has decided that they won't be entered again,
  66           that probably means that nothing has a pointer to it
  67           (not necessarily true, but...)
  68
  69         - no need to blackhole for concurrency reasons, because nothing
  70           can block on the result of this computation.
  71
  72 \begin{code}
  73 macroCode UPD_BH_UPDATABLE args = returnUs id
  74
  75 macroCode UPD_BH_SINGLE_ENTRY args = returnUs id
  76 {-
  77   = let
  78         update = StAssign PtrRep (StInd PtrRep arg) bh_info
  79     in
  80     returnUs (\xs -> update : xs)
  81 -}
  82 \end{code}
  83
  84 -----------------------------------------------------------------------------
  85 Update frames
  86
  87 Push an update frame on the stack.
  88
  89 \begin{code}
  90 macroCode PUSH_UPD_FRAME [bhptr, _{-0-}]
  91   = let
  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) 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) 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                          [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 bq_info         = StCLbl mkBlackHoleBQInfoTableLabel
 152 ind_static_info = StCLbl mkIndStaticInfoLabel
 153 ind_info        = StCLbl mkIndInfoLabel
 154 upd_frame_info  = StCLbl mkUpdInfoLabel
 155
 156 -- Some common call trees
 157 \end{code}
 158
 159 -----------------------------------------------------------------------------
 160 Heap/Stack checks
 161
 162 \begin{code}
 163 checkCode :: CCheckMacro -> [CAddrMode] -> StixStmtList -> UniqSM StixStmtList
 164 checkCode macro args assts
 165   = getUniqLabelNCG             `thenUs` \ ulbl_fail ->
 166     getUniqLabelNCG             `thenUs` \ ulbl_pass ->
 167
 168     let args_stix        = map amodeToStix args
 169         newHp wds        = StIndex PtrRep (StReg stgHp) wds
 170         assign_hp wds    = StAssignReg PtrRep stgHp (newHp wds)
 171         hp_alloc wds     = StAssignReg IntRep stgHpAlloc wds
 172         test_hp          = StMachOp MO_NatU_Le [StReg stgHp, StReg stgHpLim]
 173         cjmp_hp          = StCondJump ulbl_pass test_hp
 174         newSp wds        = StIndex PtrRep (StReg stgSp) (StMachOp MO_NatS_Neg [wds])
 175         test_sp_pass wds = StMachOp MO_NatU_Ge [newSp wds, StReg stgSpLim]
 176         test_sp_fail wds = StMachOp MO_NatU_Lt [newSp wds, StReg stgSpLim]
 177         cjmp_sp_pass wds = StCondJump ulbl_pass (test_sp_pass wds)
 178         cjmp_sp_fail wds = StCondJump ulbl_fail (test_sp_fail wds)
 179         assign_ret r ret = mkStAssign CodePtrRep r ret
 180
 181         fail = StLabel ulbl_fail
 182         join = StLabel ulbl_pass
 183
 184         -- see includes/StgMacros.h for explaination of these magic consts
 185         aLL_NON_PTRS = 0xff
 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}