[project @ 2001-05-22 13:43:14 by simonpj]

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

diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs
index ebc7aee..e6c566a 100644 (file)
--- a/ghc/compiler/nativeGen/AbsCStixGen.lhs
+++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs
@@ -24,8 +24,7 @@ import SMRep          ( fixedItblSize,
 import Constants       ( mIN_UPD_SIZE )
 import CLabel           ( CLabel, mkReturnInfoLabel, mkReturnPtLabel,
                           mkClosureTblLabel, mkClosureLabel,
-                         moduleRegdLabel, labelDynamic,
-                         mkSplitMarkerLabel )
+                         labelDynamic, mkSplitMarkerLabel )
 import ClosureInfo     ( infoTableLabelFromCI, entryLabelFromCI,
                          fastLabelFromCI, closureUpdReqd,
                          staticClosureNeedsLink
@@ -36,7 +35,7 @@ import PrimOp         ( primOpNeedsWrapper, PrimOp(..) )
 import PrimRep         ( isFloatingRep, PrimRep(..) )
 import StixInfo                ( genCodeInfoTable, genBitmapInfoTable )
 import StixMacro       ( macroCode, checkCode )
-import StixPrim                ( primCode, amodeToStix, amodeToStix' )
+import StixPrim                ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
 import Outputable       ( pprPanic, ppr )
 import UniqSupply      ( returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
 import Util            ( naturalMergeSortLe )
@@ -45,7 +44,6 @@ import TyCon          ( tyConDataCons )
 import DataCon         ( dataConWrapId )
 import BitSet          ( intBS )
 import Name             ( NamedThing(..) )
-import Char            ( ord )
 import CmdLineOpts     ( opt_Static, opt_EnsureSplittableC )
 \end{code}
 
@@ -181,7 +179,7 @@ Here we handle top-level things, like @CCodeBlock@s and
             [ StLabel tmp_lbl
             , StAssign PtrRep stgSp
                         (StIndex PtrRep stgSp (StInt (-1)))
-            , StJump (StInd WordRep stgSp)
+            , StJump NoDestInfo (StInd WordRep stgSp)
             ])
 
  gentopcode absC
@@ -223,19 +221,18 @@ Here we handle top-level things, like @CCodeBlock@s and
        = StData (promote_to_word (getAmodeRep amode)) [a2stix amode]
 
     -- We need to promote any item smaller than a word to a word
-    promote_to_word Int8Rep = IntRep
-    promote_to_word CharRep = IntRep
-    promote_to_word other   = other
+    promote_to_word pk 
+       | sizeOf pk >= sizeOf IntRep  = pk
+       | otherwise                   = IntRep
 
-    -- always at least one padding word: this is the static link field
-    -- for the garbage collector.
-    padding_wds = if closureUpdReqd cl_info then
-                       take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
-                 else
-                       []
+    upd_reqd = closureUpdReqd cl_info
 
-    static_link | staticClosureNeedsLink cl_info = [StInt 0]
-               | otherwise                      = []
+    padding_wds
+       | upd_reqd  = take (max 0 (mIN_UPD_SIZE - length amodes)) zeros
+       | otherwise = []
+
+    static_link | upd_reqd || staticClosureNeedsLink cl_info = [StInt 0]
+               | otherwise                                  = []
 
     zeros = StInt 0 : zeros
 
@@ -348,22 +345,22 @@ which varies depending on whether we're profiling etc.
 \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)
-  = returnUs (\xs -> StJump (a2stix dest) : xs)
+  = returnUs (\xs -> StJump NoDestInfo (a2stix dest) : xs)
 
  gencode (CReturn table (StaticVectoredReturn n))
-  = returnUs (\xs -> StJump dest : xs)
+  = returnUs (\xs -> StJump NoDestInfo dest : xs)
   where
     dest = StInd PtrRep (StIndex PtrRep (a2stix table)
                                  (StInt (toInteger (-n-fixedItblSize-1))))
 
  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)
     dyn_off = StPrim IntSubOp [StPrim IntNegOp [a2stix am], 
@@ -374,12 +371,15 @@ which varies depending on whether we're profiling etc.
 Now the PrimOps, some of which may need caller-saves register wrappers.
 
 \begin{code}
+ gencode (COpStmt results (StgFCallOp fcall _) args vols)
+  = ASSERT( null vols )
+    foreignCallCode (nonVoid results) fcall (nonVoid args)
 
- gencode (COpStmt results op args vols)
+ gencode (COpStmt results (StgPrimOp op) args vols)
   -- ToDo (ADR?): use that liveness mask
   | primOpNeedsWrapper op
   = let
-       saves = volsaves vols
+       saves    = volsaves vols
        restores = volrestores vols
     in
        p2stix (nonVoid results) op (nonVoid args)
@@ -389,7 +389,6 @@ Now the PrimOps, some of which may need caller-saves register wrappers.
   | otherwise = p2stix (nonVoid results) op (nonVoid args)
     where
        nonVoid = filter ((/= VoidRep) . getAmodeRep)
-
 \end{code}
 
 Now the dreaded conditional jump.
@@ -506,14 +505,14 @@ be tuned.)
        highest = if floating then targetMaxDouble else targetMaxInt
     in
        (
-       if False && -- jump tables disabled for now until the register allocator is
-                   -- fixed to cope with them --SDM 18/8/2000
-          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
        )
-                                                       `thenUs` \ alt_code ->
+                                               `thenUs` \ alt_code ->
        gencode absC                            `thenUs` \ dflt_code ->
 
        returnUs (\xs -> alt_code (StLabel udlbl : dflt_code (StLabel ujlbl : xs)))
@@ -557,8 +556,9 @@ already finish with a jump to the join point.
        cjmpHi = StCondJump dflt (StPrim IntGtOp [am, StInt (toInteger highTag)])
 
        offset = StPrim IntSubOp [am, StInt lowTag]
+        dsts   = DestInfo (dflt : map fst branches)
 
-       jump = StJump (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
+       jump = StJump dsts (StInd PtrRep (StIndex PtrRep (StCLbl utlbl) offset))
        tlbl = StLabel utlbl
        table = StData PtrRep (mkTable branches [lowTag..highTag] [])
     in