[project @ 2002-11-28 01:00:44 by mthomas]

[ghc-hetmet.git] / ghc / compiler / stgSyn / StgSyn.lhs

diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 633d5be..293aa94 100644 (file)
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -10,7 +10,7 @@ suited to spineless tagless code generation.
 
 \begin{code}
 module StgSyn (
-       GenStgArg(..),
+       GenStgArg(..), 
        GenStgLiveVars,
 
        GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
@@ -27,8 +27,11 @@ module StgSyn (
        StgBinding, StgExpr, StgRhs,
        StgCaseAlts, StgCaseDefault,
 
+       -- StgOp
+       StgOp(..),
+
        -- SRTs
-       SRT(..), noSRT,
+       SRT(..), noSRT, nonEmptySRT,
 
        -- utils
        stgBindHasCafRefs,  stgRhsArity, getArgPrimRep, 
@@ -46,15 +49,19 @@ module StgSyn (
 
 import CostCentre      ( CostCentreStack, CostCentre )
 import VarSet          ( IdSet, isEmptyVarSet )
+import Var             ( isId )
 import Id              ( Id, idName, idPrimRep, idType )
 import Name            ( isDllName )
 import Literal         ( Literal, literalType, isLitLitLit, literalPrimRep )
+import ForeignCall     ( ForeignCall )
 import DataCon         ( DataCon, dataConName )
 import PrimOp          ( PrimOp )
 import Outputable
+import Util             ( count )
 import Type             ( Type )
 import TyCon            ( TyCon )
 import UniqSet         ( isEmptyUniqSet, uniqSetToList, UniqSet )
+import Unique          ( Unique )
 import CmdLineOpts     ( opt_SccProfilingOn )
 \end{code}
 
@@ -106,6 +113,7 @@ isStgTypeArg other      = False
 
 isDllArg :: StgArg -> Bool
        -- Does this argument refer to something in a different DLL?
+isDllArg (StgTypeArg v)   = False
 isDllArg (StgVarArg v)   = isDllName (idName v)
 isDllArg (StgLitArg lit) = isLitLitLit lit
 
@@ -119,6 +127,7 @@ stgArgType :: StgArg -> Type
        -- Very half baked becase we have lost the type arguments
 stgArgType (StgVarArg v)   = idType v
 stgArgType (StgLitArg lit) = literalType lit
+stgArgType (StgTypeArg lit) = panic "stgArgType called on stgTypeArg"
 \end{code}
 
 %************************************************************************
@@ -166,7 +175,7 @@ constructors, primitives, and literals.
   | StgConApp  DataCon
                [GenStgArg occ] -- Saturated
 
-  | StgPrimApp PrimOp
+  | StgOpApp   StgOp           -- Primitive op or foreign call
                [GenStgArg occ] -- Saturated
                Type            -- Result type; we need to know the result type
                                -- so that we can assign result registers.
@@ -201,11 +210,11 @@ This has the same boxed/unboxed business as Core case expressions.
        (GenStgExpr bndr occ)
                        -- the thing to examine
 
-       (GenStgLiveVars occ) -- Live vars of whole case
-                       -- expression; i.e., those which mustn't be
-                       -- overwritten
+       (GenStgLiveVars occ) -- Live vars of whole case expression, 
+                       -- plus everything that happens after the case
+                       -- i.e., those which mustn't be overwritten
 
-       (GenStgLiveVars occ) -- Live vars of RHSs;
+       (GenStgLiveVars occ) -- Live vars of RHSs (plus what happens afterwards)
                        -- i.e., those which must be saved before eval.
                        --
                        -- note that an alt's constructor's
@@ -390,8 +399,11 @@ The second flavour of right-hand-side is for constructors (simple but important)
 \end{code}
 
 \begin{code}
-stgRhsArity :: GenStgRhs bndr occ -> Int
-stgRhsArity (StgRhsClosure _ _ _ _ args _) = length args
+stgRhsArity :: StgRhs -> Int
+stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) = count isId bndrs
+  -- The arity never includes type parameters, so
+  -- when keeping type arguments and binders in the Stg syntax 
+  -- (opt_RuntimeTypes) we have to fliter out the type binders.
 stgRhsArity (StgRhsCon _ _ _) = 0
 \end{code}
 
@@ -533,6 +545,26 @@ isUpdatable Updatable   = True
 
 %************************************************************************
 %*                                                                      *
+\subsubsection{StgOp}
+%*                                                                      *
+%************************************************************************
+
+An StgOp allows us to group together PrimOps and ForeignCalls.
+It's quite useful to move these around together, notably
+in StgOpApp and COpStmt.
+
+\begin{code}
+data StgOp = StgPrimOp  PrimOp
+
+          | StgFCallOp ForeignCall Unique
+               -- The Unique is occasionally needed by the C pretty-printer
+               -- (which lacks a unique supply), notably when generating a
+               -- typedef for foreign-export-dynamic
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
 \subsubsection[Static Reference Tables]{@SRT@}
 %*                                                                      *
 %************************************************************************
@@ -646,8 +678,8 @@ pprStgExpr (StgApp func args)
 pprStgExpr (StgConApp con args)
   = hsep [ ppr con, brackets (interppSP args)]
 
-pprStgExpr (StgPrimApp op args _)
-  = hsep [ ppr op, brackets (interppSP args)]
+pprStgExpr (StgOpApp op args _)
+  = hsep [ pprStgOp op, brackets (interppSP args)]
 
 pprStgExpr (StgLam _ bndrs body)
   =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
@@ -746,6 +778,8 @@ pprStgDefault StgNoDefault      = empty
 pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 
                                         4 (ppr expr)
 
+pprStgOp (StgPrimOp  op)   = ppr op
+pprStgOp (StgFCallOp op _) = ppr op
 \end{code}
 
 \begin{code}