[project @ 2004-08-13 10:45:16 by simonmar]

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

diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index 223b015..4a53f14 100644 (file)
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -1,43 +1,51 @@
 %
 %

-% (c) The AQUA Project, Glasgow University, 1993-1996
+% (c) The AQUA Project, Glasgow University, 1993-1998

 %
 
 \begin{code}
 %
 
 \begin{code}

-#include "HsVersions.h"
-

 module AbsCStixGen ( genCodeAbstractC ) where
 
 module AbsCStixGen ( genCodeAbstractC ) where
 

-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(Ratio(Rational))
+#include "HsVersions.h"
+
+import Ratio   ( Rational )

 
 import AbsCSyn
 import Stix
 
 import AbsCSyn
 import Stix

-

 import MachMisc
 import MachMisc

-import MachRegs

 
 import AbsCUtils       ( getAmodeRep, mixedTypeLocn,
 
 import AbsCUtils       ( getAmodeRep, mixedTypeLocn,

-                         nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
-                       )
-import CgCompInfo      ( mIN_UPD_SIZE )
-import ClosureInfo     ( infoTableLabelFromCI, entryLabelFromCI,
-                         fastLabelFromCI, closureUpdReqd
+                         nonemptyAbsC, mkAbsCStmts

                        )
                        )

-import HeapOffs                ( hpRelToInt )
-import Literal         ( Literal(..) )
-import Maybes          ( maybeToBool )
-import OrdList         ( OrdList )
-import PrimOp          ( primOpNeedsWrapper, PrimOp(..) )
-import PrimRep         ( isFloatingRep, PrimRep(..) )
-import StixInfo                ( genCodeInfoTable )
-import StixMacro       ( macroCode )
-import StixPrim                ( primCode, amodeToStix, amodeToStix' )
-import UniqSupply      ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
-import Util            ( naturalMergeSortLe, panic )
-
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
+import PprAbsC          ( dumpRealC )
+import SMRep           ( retItblSize )
+import CLabel           ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
+                          mkClosureTblLabel, mkClosureLabel,
+                         labelDynamic, mkSplitMarkerLabel )
+import ClosureInfo
+import Literal         ( Literal(..), word2IntLit )
+import StgSyn          ( StgOp(..) )
+import MachOp          ( MachOp(..), resultRepOfMachOp )
+import PrimRep         ( isFloatingRep, is64BitRep, 
+                         PrimRep(..), getPrimRepSizeInBytes )
+import StixMacro       ( macroCode, checkCode )
+import StixPrim                ( foreignCallCode, amodeToStix, amodeToStix' )
+import Outputable       ( pprPanic, ppr )
+import UniqSupply      ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import Util            ( naturalMergeSortLe )
+import Panic           ( panic )
+import TyCon           ( tyConDataCons )
+import Name             ( NamedThing(..) )
+import CmdLineOpts     ( opt_EnsureSplittableC )
+import Outputable      ( assertPanic )
+
+import Char            ( ord )
+
+-- DEBUGGING ONLY
+--import TRACE         ( trace )
+--import Outputable    ( showSDoc )
+--import MachOp                ( pprMachOp )
+
+#include "nativeGen/NCG.h"

 \end{code}
 
 For each independent chunk of AbstractC code, we generate a list of
 \end{code}
 
 For each independent chunk of AbstractC code, we generate a list of

@@ -46,19 +54,15 @@ We leave the chunks separated so that register allocation can be
 performed locally within the chunk.
 
 \begin{code}
 performed locally within the chunk.
 
 \begin{code}

-genCodeAbstractC :: AbstractC -> UniqSM [[StixTree]]
+genCodeAbstractC :: AbstractC -> UniqSM [StixStmt]

 
 genCodeAbstractC absC
 
 genCodeAbstractC absC

-  = mapUs gentopcode (mkAbsCStmtList absC) `thenUs` \ trees ->
-    returnUs ([StComment SLIT("Native Code")] : trees)
+  = gentopcode absC

  where
  a2stix      = amodeToStix
  a2stix'     = amodeToStix'
  volsaves    = volatileSaves
  volrestores = volatileRestores
  where
  a2stix      = amodeToStix
  a2stix'     = amodeToStix'
  volsaves    = volatileSaves
  volrestores = volatileRestores

- p2stix      = primCode
- macro_code  = macroCode
- hp_rel             = hpRelToInt

  -- real code follows... ---------
 \end{code}
 
  -- real code follows... ---------
 \end{code}
 

@@ -72,96 +76,135 @@ Here we handle top-level things, like @CCodeBlock@s and
     -> UniqSM [StixTree]
  -}
 
     -> UniqSM [StixTree]
  -}
 

- gentopcode (CCodeBlock label absC)
+ gentopcode (CCodeBlock lbl absC)

   = gencode absC                               `thenUs` \ code ->
   = gencode absC                               `thenUs` \ code ->

-    returnUs (StSegment TextSegment : StFunBegin label : code [StFunEnd label])
+    returnUs (StSegment TextSegment : StFunBegin lbl : code [StFunEnd lbl])

 
 

- gentopcode stmt@(CStaticClosure label _ _ _)
+ gentopcode stmt@(CStaticClosure lbl closure_info _ _)

   = genCodeStaticClosure stmt                  `thenUs` \ code ->
   = genCodeStaticClosure stmt                  `thenUs` \ code ->

-    returnUs (StSegment DataSegment : StLabel label : code [])
-
- gentopcode stmt@(CRetUnVector _ _) = returnUs []
-
- gentopcode stmt@(CFlatRetVector label _)
-  = genCodeVecTbl stmt                         `thenUs` \ code ->
-    returnUs (StSegment TextSegment : code [StLabel label])
-
- gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _ _)
-
-  | slow_is_empty
-  = genCodeInfoTable stmt              `thenUs` \ itbl ->
-    returnUs (StSegment TextSegment : itbl [])
-
-  | otherwise
-  = genCodeInfoTable stmt              `thenUs` \ itbl ->
-    gencode slow                       `thenUs` \ slow_code ->
-    returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
-             slow_code [StFunEnd slow_lbl]))
+    returnUs ( StSegment DataSegment 
+             : StLabel lbl : code []
+             )
+
+ gentopcode stmt@(CRetVector lbl amodes srt liveness)
+  = returnUs ( StSegment TextSegment
+            : StData PtrRep table
+            : StLabel lbl
+            : []
+            )

   where
   where

-    slow_is_empty = not (maybeToBool (nonemptyAbsC slow))
-    slow_lbl = entryLabelFromCI cl_info
-
- gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _ _) =
- -- ToDo: what if this is empty? ------------------------^^^^
-    genCodeInfoTable stmt              `thenUs` \ itbl ->
-    gencode slow                       `thenUs` \ slow_code ->
-    gencode fast                       `thenUs` \ fast_code ->
-    returnUs (StSegment TextSegment : itbl (StFunBegin slow_lbl :
-             slow_code (StFunEnd slow_lbl : StFunBegin fast_lbl :
-             fast_code [StFunEnd fast_lbl])))
+    table = map amodeToStix (mkVecInfoTable amodes srt liveness)
+
+ gentopcode stmt@(CRetDirect uniq absC srt liveness)
+  = gencode absC                                      `thenUs` \ code ->
+    returnUs ( StSegment TextSegment
+            : StData PtrRep table
+            : StLabel info_lbl
+            : StLabel ret_lbl
+            : code [])
+  where 
+    info_lbl = mkReturnInfoLabel uniq
+    ret_lbl  = mkReturnPtLabel uniq
+    table    = map amodeToStix (mkRetInfoTable ret_lbl srt liveness)
+
+ gentopcode stmt@(CClosureInfoAndCode cl_info entry)
+  = gencode entry                      `thenUs` \ slow_code ->
+    returnUs ( StSegment TextSegment
+            : StData PtrRep table
+            : StLabel info_lbl
+            : StFunBegin entry_lbl
+            : slow_code [StFunEnd entry_lbl])

   where
   where

-    slow_lbl = entryLabelFromCI cl_info
-    fast_lbl = fastLabelFromCI cl_info
+    entry_lbl = entryLabelFromCI cl_info
+    info_lbl = infoTableLabelFromCI cl_info
+    table    = map amodeToStix (mkInfoTable cl_info)
+
+ gentopcode stmt@(CSRT lbl closures)
+  = returnUs [ StSegment TextSegment 
+            , StLabel lbl 
+            , StData DataPtrRep (map mk_StCLbl_for_SRT closures)
+            ]
+    where
+       mk_StCLbl_for_SRT :: CLabel -> StixExpr
+       mk_StCLbl_for_SRT label
+          | labelDynamic label
+          = StIndex Int8Rep (StCLbl label) (StInt 1)
+          | otherwise
+          = StCLbl label
+
+ gentopcode stmt@(CBitmap l@(Liveness lbl size mask))
+  = returnUs 
+       [ StSegment TextSegment 
+       , StLabel lbl 
+       , StData WordRep (map StInt (toInteger size : map toInteger mask))
+       ]
+
+ gentopcode stmt@(CSRTDesc lbl srt_lbl off len bitmap)
+  = returnUs 
+       [ StSegment TextSegment 
+       , StLabel lbl 
+       , StData WordRep (
+               StIndex PtrRep (StCLbl srt_lbl) (StInt (toInteger off)) :
+               map StInt (toInteger len : map toInteger bitmap)
+           )
+       ]
+
+ gentopcode stmt@(CClosureTbl tycon)
+  = returnUs [ StSegment TextSegment
+             , StLabel (mkClosureTblLabel tycon)
+             , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName) 
+                                      (tyConDataCons tycon) )
+             ]
+
+ gentopcode stmt@(CModuleInitBlock plain_lbl lbl absC)
+  = gencode absC                       `thenUs` \ code ->
+    getUniqLabelNCG                    `thenUs` \ tmp_lbl ->
+    getUniqLabelNCG                    `thenUs` \ flag_lbl ->
+    returnUs ( StSegment DataSegment
+            : StLabel flag_lbl
+            : StData IntRep [StInt 0]
+            : StSegment TextSegment
+            : StLabel plain_lbl
+            : StJump NoDestInfo (StCLbl lbl)
+            : StLabel lbl
+            : StCondJump tmp_lbl (StMachOp MO_Nat_Ne
+                                    [StInd IntRep (StCLbl flag_lbl),
+                                     StInt 0])
+            : StAssignMem IntRep (StCLbl flag_lbl) (StInt 1)
+            : code 
+            [ StLabel tmp_lbl
+            , StAssignReg PtrRep stgSp
+                           (StIndex PtrRep (StReg stgSp) (StInt (-1)))
+            , StJump NoDestInfo (StInd WordRep (StReg stgSp))
+            ])

 
  gentopcode absC
   = gencode absC                               `thenUs` \ code ->
     returnUs (StSegment TextSegment : code [])
 
  gentopcode absC
   = gencode absC                               `thenUs` \ code ->
     returnUs (StSegment TextSegment : code [])

-
-\end{code}
-
-Vector tables are trivial!
-
-\begin{code}
- {-
- genCodeVecTbl
-    :: AbstractC
-    -> UniqSM StixTreeList
- -}
- genCodeVecTbl (CFlatRetVector label amodes)
-  = returnUs (\xs -> vectbl : xs)
-  where
-    vectbl = StData PtrRep (reverse (map a2stix amodes))
-

 \end{code}
 
 \end{code}
 

-Static closures are not so hard either.
-

 \begin{code}
  {-
  genCodeStaticClosure
     :: AbstractC
     -> UniqSM StixTreeList
  -}
 \begin{code}
  {-
  genCodeStaticClosure
     :: AbstractC
     -> UniqSM StixTreeList
  -}

- genCodeStaticClosure (CStaticClosure _ cl_info cost_centre amodes)
-  = returnUs (\xs -> table : xs)
+ genCodeStaticClosure (CStaticClosure lbl cl_info cost_centre amodes)
+  = returnUs (\xs -> table ++ xs)

   where
   where

-    table = StData PtrRep (StCLbl info_lbl : body)
-    info_lbl = infoTableLabelFromCI cl_info
-
-    body = if closureUpdReqd cl_info then
-               take (max mIN_UPD_SIZE (length amodes')) (amodes' ++ zeros)
-          else
-               amodes'
-
-    zeros = StInt 0 : zeros
-
-    amodes' = map amodeZeroVoid amodes
-
-       -- Watch out for VoidKinds...cf. PprAbsC
-    amodeZeroVoid item
-      | getAmodeRep item == VoidRep = StInt 0
-      | otherwise = a2stix item
-
+    table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] : 
+           foldr do_one_amode [] amodes
+
+    do_one_amode amode rest
+       | rep == VoidRep = rest
+       | otherwise      = StData (promote_to_word rep) [a2stix amode] : rest
+       where 
+         rep = getAmodeRep amode
+
+    -- We need to promote any item smaller than a word to a word
+    promote_to_word pk 
+       | getPrimRepSizeInBytes pk >= getPrimRepSizeInBytes IntRep  = pk
+       | otherwise                                                 = IntRep

 \end{code}
 
 Now the individual AbstractC statements.
 \end{code}
 
 Now the individual AbstractC statements.

@@ -182,11 +225,14 @@ Now the individual AbstractC statements.
 
 \end{code}
 
 
 \end{code}
 

-Split markers are a NOP in this land.
+Split markers just insert a __stg_split_marker, which is caught by the
+split-mangler later on and used to split the assembly into chunks.

 
 \begin{code}
 
 
 \begin{code}
 

- gencode CSplitMarker = returnUs id
+ gencode CSplitMarker
+   | opt_EnsureSplittableC = returnUs (\xs -> StLabel mkSplitMarkerLabel : xs)
+   | otherwise             = returnUs id

 
 \end{code}
 
 
 \end{code}
 

@@ -200,6 +246,14 @@ resulting StixTreeLists are joined together.
     gencode c2                         `thenUs` \ b2 ->
     returnUs (b1 . b2)
 
     gencode c2                         `thenUs` \ b2 ->
     returnUs (b1 . b2)
 

+ gencode (CSequential stuff)
+  = foo stuff
+    where
+       foo [] = returnUs id
+       foo (s:ss) = gencode s  `thenUs` \ stix ->
+                    foo ss     `thenUs` \ stixes ->
+                    returnUs (stix . stixes)
+

 \end{code}
 
 Initialising closure headers in the heap...a fairly complex ordeal if
 \end{code}
 
 Initialising closure headers in the heap...a fairly complex ordeal if

@@ -212,10 +266,20 @@ addresses, etc.)
 
  gencode (CInitHdr cl_info reg_rel _ _)
   = let
 
  gencode (CInitHdr cl_info reg_rel _ _)
   = let

-       lhs = a2stix (CVal reg_rel PtrRep)
+       lhs = a2stix reg_rel

        lbl = infoTableLabelFromCI cl_info
     in
        lbl = infoTableLabelFromCI cl_info
     in

-       returnUs (\xs -> StAssign PtrRep lhs (StCLbl lbl) : xs)
+       returnUs (\xs -> StAssignMem PtrRep lhs (StCLbl lbl) : xs)
+
+\end{code}
+
+Heap/Stack Checks.
+
+\begin{code}
+
+ gencode (CCheck macro args assts)
+  = gencode assts `thenUs` \assts_stix ->
+    checkCode macro args assts_stix

 
 \end{code}
 
 
 \end{code}
 

@@ -229,14 +293,23 @@ of the source?  Be careful about floats/doubles.
 \begin{code}
 
  gencode (CAssign lhs rhs)
 \begin{code}
 
  gencode (CAssign lhs rhs)

-  | getAmodeRep lhs == VoidRep = returnUs id
+  | lhs_rep == VoidRep 
+  = returnUs id

   | otherwise
   | otherwise

-  = let pk = getAmodeRep lhs
-       pk' = if mixedTypeLocn lhs && not (isFloatingRep pk) then IntRep else pk
+  = let -- This is a Hack.  Should be cleaned up.
+        -- JRS, 10 Dec 01
+        pk' | ncg_target_is_32bit && is64BitRep lhs_rep
+            = lhs_rep
+            | otherwise
+            = if   mixedTypeLocn lhs && not (isFloatingRep lhs_rep) 
+              then IntRep 
+              else lhs_rep

        lhs' = a2stix lhs
        rhs' = a2stix' rhs
     in
        lhs' = a2stix lhs
        rhs' = a2stix' rhs
     in

-       returnUs (\xs -> StAssign pk' lhs' rhs' : xs)
+       returnUs (\xs -> mkStAssign pk' lhs' rhs' : xs)
+    where 
+       lhs_rep = getAmodeRep lhs

 
 \end{code}
 
 
 \end{code}
 

@@ -244,50 +317,51 @@ Unconditional jumps, including the special ``enter closure'' operation.
 Note that the new entry convention requires that we load the InfoPtr (R2)
 with the address of the info table before jumping to the entry code for Node.
 
 Note that the new entry convention requires that we load the InfoPtr (R2)
 with the address of the info table before jumping to the entry code for Node.
 

+For a vectored return, we must subtract the size of the info table to
+get at the return vector.  This depends on the size of the info table,
+which varies depending on whether we're profiling etc.
+

 \begin{code}
 
  gencode (CJump dest)
 \begin{code}
 
  gencode (CJump dest)

-  = returnUs (\xs -> StJump (a2stix dest) : xs)
+  = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)

 
  gencode (CFallThrough (CLbl lbl _))
   = returnUs (\xs -> StFallThrough lbl : xs)
 
  gencode (CReturn dest DirectReturn)
 
  gencode (CFallThrough (CLbl lbl _))
   = returnUs (\xs -> StFallThrough lbl : xs)
 
  gencode (CReturn dest DirectReturn)

-  = returnUs (\xs -> StJump (a2stix dest) : xs)
+  = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)

 
  gencode (CReturn table (StaticVectoredReturn n))
 
  gencode (CReturn table (StaticVectoredReturn n))

-  = returnUs (\xs -> StJump dest : xs)
+  = returnUs (\xs -> StJump NoDestInfo dest : xs)

   where
     dest = StInd PtrRep (StIndex PtrRep (a2stix table)
   where
     dest = StInd PtrRep (StIndex PtrRep (a2stix table)

-                                         (StInt (toInteger (-n-1))))
+                                 (StInt (toInteger (-n-retItblSize-1))))

 
  gencode (CReturn table (DynamicVectoredReturn am))
 
  gencode (CReturn table (DynamicVectoredReturn am))

-  = returnUs (\xs -> StJump dest : xs)
+  = returnUs (\xs -> StJump NoDestInfo dest : xs)

   where
     dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)
   where
     dest = StInd PtrRep (StIndex PtrRep (a2stix table) dyn_off)

-    dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], StInt 1]
+    dyn_off = StMachOp MO_Nat_Sub [StMachOp MO_NatS_Neg [a2stix am], 
+                                  StInt (toInteger (retItblSize+1))]

 
 \end{code}
 
 Now the PrimOps, some of which may need caller-saves register wrappers.
 
 \begin{code}
 
 \end{code}
 
 Now the PrimOps, some of which may need caller-saves register wrappers.
 
 \begin{code}

-
- gencode (COpStmt results op args liveness_mask vols)
-  -- ToDo (ADR?): use that liveness mask
-  | primOpNeedsWrapper op
-  = let
-       saves = volsaves vols
-       restores = volrestores vols
-    in
-       p2stix (nonVoid results) op (nonVoid args)
-                                                       `thenUs` \ code ->
-       returnUs (\xs -> saves ++ code (restores ++ xs))
-
-  | otherwise = p2stix (nonVoid results) op (nonVoid args)
-    where
-       nonVoid = filter ((/= VoidRep) . getAmodeRep)
-
+ gencode (COpStmt results (StgFCallOp fcall _) args vols)
+  = ASSERT( null vols )
+    foreignCallCode (nonVoid results) fcall (nonVoid args)
+
+ gencode (COpStmt results (StgPrimOp op) args vols)
+  = panic "AbsCStixGen.gencode: un-translated PrimOp"
+
+ gencode (CMachOpStmt res mop args vols)
+  = returnUs (\xs -> mkStAssign (resultRepOfMachOp mop) (a2stix res) 
+                                (StMachOp mop (map a2stix args))
+                     : xs
+             )

 \end{code}
 
 Now the dreaded conditional jump.
 \end{code}
 
 Now the dreaded conditional jump.

@@ -316,8 +390,8 @@ Now the if statement.  Almost *all* flow of control are of this form.
                                Nothing -> gencode alt_code
                                Just dc -> mkIfThenElse discrim tag alt_code dc
 
                                Nothing -> gencode alt_code
                                Just dc -> mkIfThenElse discrim tag alt_code dc
 

-      [(tag1@(MachInt i1 _), alt_code1),
-       (tag2@(MachInt i2 _), alt_code2)]
+      [(tag1@(MachInt i1), alt_code1),
+       (tag2@(MachInt i2), alt_code2)]

        | deflt_is_empty && i1 == 0 && i2 == 1
        -> mkIfThenElse discrim tag1 alt_code1 alt_code2
        | deflt_is_empty && i1 == 1 && i2 == 0
        | deflt_is_empty && i1 == 0 && i2 == 1
        -> mkIfThenElse discrim tag1 alt_code1 alt_code2
        | deflt_is_empty && i1 == 1 && i2 == 0

@@ -327,7 +401,7 @@ Now the if statement.  Almost *all* flow of control are of this form.
       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 
        -- Otherwise, we need to do a bit of work.
       other | simple_discrim -> mkSimpleSwitches discrim alts deflt
 
        -- Otherwise, we need to do a bit of work.

-      other ->  getUnique                        `thenUs` \ u ->
+      other ->  getUniqueUs                      `thenUs` \ u ->

                gencode (AbsCStmts
                (CAssign (CTemp u pk) discrim)
                (CSwitch (CTemp u pk) alts deflt))
                gencode (AbsCStmts
                (CAssign (CTemp u pk) discrim)
                (CSwitch (CTemp u pk) alts deflt))

@@ -352,7 +426,7 @@ Finally, all of the disgusting AbstractC macros.
 
 \begin{code}
 
 
 \begin{code}
 

- gencode (CMacroStmt macro args) = macro_code macro args
+ gencode (CMacroStmt macro args) = macroCode macro (map amodeToStix args)

 
  gencode (CCallProfCtrMacro macro _)
   = returnUs (\xs -> StComment macro : xs)
 
  gencode (CCallProfCtrMacro macro _)
   = returnUs (\xs -> StComment macro : xs)

@@ -360,24 +434,32 @@ Finally, all of the disgusting AbstractC macros.
  gencode (CCallProfCCMacro macro _)
   = returnUs (\xs -> StComment macro : xs)
 
  gencode (CCallProfCCMacro macro _)
   = returnUs (\xs -> StComment macro : xs)
 

+ gencode CCallTypedef{} = returnUs id
+
+ gencode other
+  = pprPanic "AbsCStixGen.gencode" (dumpRealC other)
+
+ nonVoid = filter ((/= VoidRep) . getAmodeRep)

 \end{code}
 
 \end{code}
 

-Here, we generate a jump table if there are more than four (integer) alternatives and
-the jump table occupancy is greater than 50%.  Otherwise, we generate a binary
-comparison tree.  (Perhaps this could be tuned.)
+Here, we generate a jump table if there are more than four (integer)
+alternatives and the jump table occupancy is greater than 50%.
+Otherwise, we generate a binary comparison tree.  (Perhaps this could
+be tuned.)

 
 \begin{code}
 
  intTag :: Literal -> Integer
 
 \begin{code}
 
  intTag :: Literal -> Integer

- intTag (MachChar c) = toInteger (ord c)
- intTag (MachInt i _) = i
- intTag _ = panic "intTag"
+ intTag (MachChar c)  = toInteger (ord c)
+ intTag (MachInt i)   = i
+ intTag (MachWord w)  = intTag (word2IntLit (MachWord w))
+ intTag _             = panic "intTag"

 
  fltTag :: Literal -> Rational
 
 
  fltTag :: Literal -> Rational
 

- fltTag (MachFloat f) = f
+ fltTag (MachFloat f)  = f

  fltTag (MachDouble d) = d
  fltTag (MachDouble d) = d

- fltTag _ = panic "fltTag"
+ fltTag x              = pprPanic "fltTag" (ppr x)

 
  {-
  mkSimpleSwitches
 
  {-
  mkSimpleSwitches

@@ -400,12 +482,14 @@ comparison tree.  (Perhaps this could be tuned.)
        highest = if floating then targetMaxDouble else targetMaxInt
     in
        (
        highest = if floating then targetMaxDouble else targetMaxInt
     in
        (

-       if not floating && choices > 4 && highTag - lowTag < toInteger (2 * choices) then
+       if  not floating && choices > 4 
+            && highTag - lowTag < toInteger (2 * choices)
+        then

            mkJumpTable am' sortedAlts lowTag highTag udlbl
        else
            mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
        )
            mkJumpTable am' sortedAlts lowTag highTag udlbl
        else
            mkBinaryTree am' floating sortedAlts choices lowest highest udlbl
        )

-                                                       `thenUs` \ alt_code ->
+                                               `thenUs` \ alt_code ->

        gencode absC                            `thenUs` \ dflt_code ->
 
        returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
        gencode absC                            `thenUs` \ dflt_code ->
 
        returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))

@@ -415,7 +499,8 @@ comparison tree.  (Perhaps this could be tuned.)
        choices = length alts
 
        (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y
        choices = length alts
 
        (x@(MachChar _),_)  `leAlt` (y,_) = intTag x <= intTag y

-       (x@(MachInt _ _),_) `leAlt` (y,_) = intTag x <= intTag y
+       (x@(MachInt _), _)  `leAlt` (y,_) = intTag x <= intTag y
+       (x@(MachWord _), _) `leAlt` (y,_) = intTag x <= intTag y

        (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 
 \end{code}
        (x,_)               `leAlt` (y,_) = fltTag x <= fltTag y
 
 \end{code}

@@ -444,12 +529,13 @@ already finish with a jump to the join point.
  mkJumpTable am alts lowTag highTag dflt
   = getUniqLabelNCG                                    `thenUs` \ utlbl ->
     mapUs genLabel alts                                `thenUs` \ branches ->
  mkJumpTable am alts lowTag highTag dflt
   = getUniqLabelNCG                                    `thenUs` \ utlbl ->
     mapUs genLabel alts                                `thenUs` \ branches ->

-    let        cjmpLo = StCondJump dflt (StPrim IntLtOp [am, StInt lowTag])
-       cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt highTag])
+    let        cjmpLo = StCondJump dflt (StMachOp MO_NatS_Lt [am, StInt (toInteger lowTag)])
+       cjmpHi = StCondJump dflt (StMachOp MO_NatS_Gt [am, StInt (toInteger highTag)])

 
 

-       offset = StPrim IntSubOp [am, StInt lowTag]
-       jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
+       offset = StMachOp MO_Nat_Sub [am, StInt lowTag]
+        dsts   = DestInfo (dflt : map fst branches)

 
 

+       jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))

        tlbl = StLabel utlbl
        table = StData PtrRep (mkTable branches [lowTag..highTag] [])
     in
        tlbl = StLabel utlbl
        table = StData PtrRep (mkTable branches [lowTag..highTag] [])
     in

@@ -503,8 +589,8 @@ alternatives should already finish with a jump to the join point.
   | rangeOfOne = gencode alt
   | otherwise
   = let        tag' = a2stix (CLit tag)
   | rangeOfOne = gencode alt
   | otherwise
   = let        tag' = a2stix (CLit tag)

-       cmpOp = if floating then DoubleNeOp else IntNeOp
-       test = StPrim cmpOp [am, tag']
+       cmpOp = if floating then MO_Dbl_Ne else MO_Nat_Ne
+       test = StMachOp cmpOp [am, tag']

        cjmp = StCondJump udlbl test
     in
        gencode alt                             `thenUs` \ alt_code ->
        cjmp = StCondJump udlbl test
     in
        gencode alt                             `thenUs` \ alt_code ->

@@ -517,8 +603,8 @@ alternatives should already finish with a jump to the join point.
  mkBinaryTree am floating alts choices lowTag highTag udlbl
   = getUniqLabelNCG                                    `thenUs` \ uhlbl ->
     let tag' = a2stix (CLit splitTag)
  mkBinaryTree am floating alts choices lowTag highTag udlbl
   = getUniqLabelNCG                                    `thenUs` \ uhlbl ->
     let tag' = a2stix (CLit splitTag)

-       cmpOp = if floating then DoubleGeOp else IntGeOp
-       test = StPrim cmpOp [am, tag']
+       cmpOp = if floating then MO_Dbl_Ge else MO_NatS_Ge
+       test = StMachOp cmpOp [am, tag']

        cjmp = StCondJump uhlbl test
     in
        mkBinaryTree am floating alts_lo half lowTag splitTag udlbl
        cjmp = StCondJump uhlbl test
     in
        mkBinaryTree am floating alts_lo half lowTag splitTag udlbl

@@ -550,8 +636,8 @@ alternatives should already finish with a jump to the join point.
     getUniqLabelNCG                                    `thenUs` \ utlbl ->
     let discrim' = a2stix discrim
        tag' = a2stix (CLit tag)
     getUniqLabelNCG                                    `thenUs` \ utlbl ->
     let discrim' = a2stix discrim
        tag' = a2stix (CLit tag)

-       cmpOp = if (isFloatingRep (getAmodeRep discrim)) then DoubleNeOp else IntNeOp
-       test = StPrim cmpOp [discrim', tag']
+       cmpOp = if (isFloatingRep (getAmodeRep discrim)) then MO_Dbl_Ne else MO_Nat_Ne
+       test = StMachOp cmpOp [discrim', tag']

        cjmp = StCondJump utlbl test
        dest = StLabel utlbl
        join = StLabel ujlbl
        cjmp = StCondJump utlbl test
        dest = StLabel utlbl
        join = StLabel ujlbl

@@ -560,8 +646,8 @@ alternatives should already finish with a jump to the join point.
        gencode deflt                           `thenUs` \ dflt_code ->
        returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 
        gencode deflt                           `thenUs` \ dflt_code ->
        returnUs (\xs -> cjmp : alt_code (dest : dflt_code (join : xs)))
 

-mkJoin :: AbstractC -> CLabel -> AbstractC

 
 

+mkJoin :: AbstractC -> CLabel -> AbstractC

 mkJoin code lbl
   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
   | otherwise = code
 mkJoin code lbl
   | mightFallThrough code = mkAbsCStmts code (CJump (CLbl lbl PtrRep))
   | otherwise = code