[project @ 2001-10-26 11:53:34 by sewardj]

[ghc-hetmet.git] / ghc / compiler / nativeGen / Stix.lhs

diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs
index 06854db..10a015e 100644 (file)
--- a/ghc/compiler/nativeGen/Stix.lhs
+++ b/ghc/compiler/nativeGen/Stix.lhs
@@ -22,17 +22,20 @@ module Stix (
         uniqOfNatM_State, deltaOfNatM_State,
 
        getUniqLabelNCG, getNatLabelNCG,
+        ncgPrimopMoan
     ) where
 
 #include "HsVersions.h"
 
 import Ratio           ( Rational )
+import IOExts          ( unsafePerformIO )
+import IO              ( hPutStrLn, stderr )
 
 import AbsCSyn         ( node, tagreg, MagicId(..) )
-import CallConv                ( CallConv, pprCallConv )
+import ForeignCall     ( CCallConv )
 import CLabel          ( mkAsmTempLabel, CLabel, pprCLabel )
-import PrimRep          ( PrimRep(..), showPrimRep )
-import PrimOp           ( PrimOp, pprPrimOp )
+import PrimRep          ( PrimRep(..) )
+import PrimOp           ( PrimOp )
 import Unique           ( Unique )
 import SMRep           ( fixedHdrSize, arrWordsHdrSize, arrPtrsHdrSize )
 import UniqSupply      ( UniqSupply, splitUniqSupply, uniqFromSupply,
@@ -112,7 +115,7 @@ data StixTree
 
     -- Calls to C functions
 
-  | StCall FAST_STRING CallConv PrimRep [StixTree]
+  | StCall FAST_STRING CCallConv PrimRep [StixTree]
 
     -- A volatile memory scratch array, which is allocated
     -- relative to the stack pointer.  It is an array of
@@ -163,9 +166,9 @@ pprStixTree t
        StCLbl lbl       -> pprCLabel lbl
        StReg reg        -> ppStixReg reg
        StIndex k b o    -> paren (pprStixTree b <+> char '+' <> 
-                                  pprPrimRep k <+> pprStixTree o)
-       StInd k t        -> pprPrimRep k <> char '[' <> pprStixTree t <> char ']'
-       StAssign k d s   -> pprStixTree d <> text "  :=" <> pprPrimRep k 
+                                  ppr k <+> pprStixTree o)
+       StInd k t        -> ppr k <> char '[' <> pprStixTree t <> char ']'
+       StAssign k d s   -> pprStixTree d <> text "  :=" <> ppr k 
                                          <> text "  " <> pprStixTree s
        StLabel ll       -> pprCLabel ll <+> char ':'
        StFunBegin ll    -> char ' ' $$ paren (text "FunBegin" <+> pprCLabel ll)
@@ -174,17 +177,15 @@ pprStixTree t
        StFallThrough ll -> paren (text "FallThru" <+> pprCLabel ll)
        StCondJump l t   -> paren (text "JumpC" <+> pprCLabel l 
                                                <+> pprStixTree t)
-       StData k ds      -> paren (text "Data" <+> pprPrimRep k <+>
+       StData k ds      -> paren (text "Data" <+> ppr k <+>
                                   hsep (map pprStixTree ds))
-       StPrim op ts     -> paren (text "Prim" <+> pprPrimOp op <+> 
+       StPrim op ts     -> paren (text "Prim" <+> ppr op <+> 
                                   hsep (map pprStixTree ts))
        StCall nm cc k args
                         -> paren (text "Call" <+> ptext nm <+>
-                                  pprCallConv cc <+> pprPrimRep k <+> 
+                                  ppr cc <+> ppr k <+> 
                                   hsep (map pprStixTree args))
        StScratchWord i  -> text "ScratchWord" <> paren (int i)
-
-pprPrimRep = text . showPrimRep
 \end{code}
 
 Stix registers can have two forms.  They {\em may} or {\em may not}
@@ -204,11 +205,11 @@ ppStixReg (StixTemp u pr)
 
 
 ppMId BaseReg              = text "BaseReg"
-ppMId (VanillaReg kind n)  = hcat [pprPrimRep kind, text "IntReg(", 
+ppMId (VanillaReg kind n)  = hcat [ppr kind, text "IntReg(", 
                                    int (iBox n), char ')']
 ppMId (FloatReg n)         = hcat [text "FltReg(", int (iBox n), char ')']
 ppMId (DoubleReg n)        = hcat [text "DblReg(", int (iBox n), char ')']
-ppMId (LongReg kind n)     = hcat [pprPrimRep kind, text "LongReg(", 
+ppMId (LongReg kind n)     = hcat [ppr kind, text "LongReg(", 
                                    int (iBox n), char ')']
 ppMId Sp                   = text "Sp"
 ppMId Su                   = text "Su"
@@ -406,3 +407,23 @@ setDeltaNat :: Int -> NatM ()
 setDeltaNat delta (NatM_State us _)
    = ((), NatM_State us delta)
 \end{code}
+
+Giving up in a not-too-inelegant way.
+
+\begin{code}
+ncgPrimopMoan :: String -> SDoc -> a
+ncgPrimopMoan msg pp_rep
+   = unsafePerformIO (
+        hPutStrLn stderr (
+        "\n" ++
+        "You've fallen across an unimplemented case in GHC's native code generation\n" ++
+        "machinery.  You can work around this for the time being by compiling\n" ++ 
+        "this module via the C route, by giving the flag -fvia-C.\n" ++
+        "The panic below contains information, intended for the GHC implementors,\n" ++
+        "about the exact place where GHC gave up.  Please send it to us\n" ++
+        "at glasgow-haskell-bugs@haskell.org, so as to encourage us to fix this.\n"
+        )
+     )
+     `seq`
+     pprPanic msg pp_rep
+\end{code}