FIX panic from the GHC API

[ghc-hetmet.git] / compiler / codeGen / CgUtils.hs

diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index a4d2338..c48b584 100644 (file)
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -9,7 +9,9 @@
 module CgUtils (
        addIdReps,
        cgLit,
-       emitDataLits, emitRODataLits, emitIf, emitIfThenElse,
+       emitDataLits, mkDataLits,
+        emitRODataLits, mkRODataLits,
+        emitIf, emitIfThenElse,
        emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
        assignNonPtrTemp, newNonPtrTemp,
        assignPtrTemp, newPtrTemp,
@@ -29,7 +31,9 @@ module CgUtils (
        mkWordCLit,
        mkStringCLit, mkByteStringCLit,
        packHalfWordsCLit,
-       blankWord
+       blankWord,
+
+       getSRTInfo
   ) where
 
 #include "HsVersions.h"
@@ -45,6 +49,8 @@ import CLabel
 import CmmUtils
 import MachOp
 import ForeignCall
+import ClosureInfo
+import StgSyn (SRT(..))
 import Literal
 import Digraph
 import ListSetOps
@@ -263,18 +269,18 @@ emitIfThenElse cond then_part else_part
        ; labelC join_id
        }
 
-emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code
-emitRtsCall fun args = emitRtsCall' [] fun args Nothing
+emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
+emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
    -- The 'Nothing' says "save all global registers"
 
-emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code
-emitRtsCallWithVols fun args vols
-   = emitRtsCall' [] fun args (Just vols)
+emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
+emitRtsCallWithVols fun args vols safe
+   = emitRtsCall' [] fun args (Just vols) safe
 
 emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
-       -> [(CmmExpr,MachHint)] -> Code
-emitRtsCallWithResult res hint fun args
-   = emitRtsCall' [(res,hint)] fun args Nothing
+       -> [(CmmExpr,MachHint)] -> Bool -> Code
+emitRtsCallWithResult res hint fun args safe
+   = emitRtsCall' [(res,hint)] fun args Nothing safe
 
 -- Make a call to an RTS C procedure
 emitRtsCall'
@@ -282,11 +288,15 @@ emitRtsCall'
    -> LitString
    -> [(CmmExpr,MachHint)]
    -> Maybe [GlobalReg]
+   -> Bool -- True <=> CmmSafe call
    -> Code
-emitRtsCall' res fun args vols = do
-    stmtsC caller_save
-    stmtC (CmmCall target res args)
-    stmtsC caller_load
+emitRtsCall' res fun args vols safe = do
+  safety <- if safe
+            then getSRTInfo >>= (return . CmmSafe)
+            else return CmmUnsafe
+  stmtsC caller_save
+  stmtC (CmmCall target res args safety)
+  stmtsC caller_load
   where
     (caller_save, caller_load) = callerSaveVolatileRegs vols
     target   = CmmForeignCall fun_expr CCallConv
@@ -304,6 +314,11 @@ emitDataLits :: CLabel -> [CmmLit] -> Code
 emitDataLits lbl lits
   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+-- Emit a data-segment data block
+mkDataLits lbl lits
+  = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+
 emitRODataLits :: CLabel -> [CmmLit] -> Code
 -- Emit a read-only data block
 emitRODataLits lbl lits
@@ -314,6 +329,15 @@ emitRODataLits lbl lits
         needsRelocation (CmmLabelOff _ _) = True
         needsRelocation _                 = False
 
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkRODataLits lbl lits
+  = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
+  where section | any needsRelocation lits = RelocatableReadOnlyData
+                | otherwise                = ReadOnlyData
+        needsRelocation (CmmLabel _)      = True
+        needsRelocation (CmmLabelOff _ _) = True
+        needsRelocation _                 = False
+
 mkStringCLit :: String -> FCode CmmLit
 -- Make a global definition for the string,
 -- and return its label
@@ -705,3 +729,38 @@ possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 
 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 possiblySameLoc l1 rep1 l2        rep2 = True  -- Conservative
+
+-------------------------------------------------------------------------
+--
+--     Static Reference Tables
+--
+-------------------------------------------------------------------------
+
+-- There is just one SRT for each top level binding; all the nested
+-- bindings use sub-sections of this SRT.  The label is passed down to
+-- the nested bindings via the monad.
+
+getSRTInfo :: FCode C_SRT
+getSRTInfo = do
+  srt_lbl <- getSRTLabel
+  srt <- getSRT
+  case srt of
+    -- TODO: Should we panic in this case?
+    -- Someone obviously thinks there should be an SRT
+    NoSRT -> return NoC_SRT
+    SRT off len bmp
+      | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
+      -> do id <- newUnique
+            let srt_desc_lbl = mkLargeSRTLabel id
+           emitRODataLits srt_desc_lbl
+             ( cmmLabelOffW srt_lbl off
+              : mkWordCLit (fromIntegral len)
+              : map mkWordCLit bmp)
+           return (C_SRT srt_desc_lbl 0 srt_escape)
+
+    SRT off len bmp
+      | otherwise 
+      -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+               -- The fromIntegral converts to StgHalfWord
+
+srt_escape = (-1) :: StgHalfWord