X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsCore.lhs;h=183702701580cde6e448a7db36479980cb675bad;hb=b822aa0e9411a1909988c0367d342671806a0f75;hp=0154c84d6de6c44fd3e4d46bd7578a179bdd08c2;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 0154c84..1837027 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
 %************************************************************************
 %*									*
@@ -11,27 +11,28 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
 @TyVars@ as well.  Currently trying the former... MEGA SIGH.
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsCore (
-	UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
-	UfDefault(..), UfBinding(..),
-	UfArg(..), UfPrimOp(..)
+	UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
+	UfBinding(..), UfConAlt(..),
+	HsIdInfo(..), HsStrictnessInfo(..),
+	IfaceSig(..), UfRuleBody(..)
     ) where
 
-IMP_Ubiq()
+#include "HsVersions.h"
 
 -- friends:
 import HsTypes		( HsType, pprParendHsType )
-import PrimOp		( PrimOp, tagOf_PrimOp )
-import Kind		( Kind {- instance Outputable -} )
-import Type		( GenType {- instance Outputable -} )
 
 -- others:
+import IdInfo		( ArityInfo, UpdateInfo, InlinePragInfo )
+import CoreSyn		( CoreBndr, CoreExpr )
+import Demand		( Demand )
 import Literal		( Literal )
-import Outputable	( Outputable(..) )
-import Pretty
-import Util		( panic )
+import PrimOp		( CCall, pprCCallOp )
+import Type		( Kind )
+import CostCentre
+import SrcLoc		( SrcLoc )
+import Outputable
 \end{code}
 
 %************************************************************************
@@ -43,38 +44,28 @@ import Util		( panic )
 \begin{code}
 data UfExpr name
   = UfVar 	name
-  | UfLit	Literal
-  | UfCon 	name [UfArg name]
-  | UfPrim	(UfPrimOp name) [UfArg name]
+  | UfType      (HsType name)
+  | UfTuple 	name [UfExpr name]		-- Type arguments omitted
   | UfLam 	(UfBinder name)	  (UfExpr name)
-  | UfApp 	(UfExpr name) (UfArg name)
-  | UfCase	(UfExpr name) (UfAlts name)
+  | UfApp 	(UfExpr name) (UfExpr name)
+  | UfCase	(UfExpr name) name [UfAlt name]
   | UfLet	(UfBinding name)  (UfExpr name)
-  | UfSCC	CostCentre (UfExpr name)
-  | UfCoerce	(UfCoercion name) (HsType name) (UfExpr name)
-
-data UfPrimOp name
-  = UfCCallOp	FAST_STRING	     -- callee
-		Bool		     -- True <=> casm, rather than ccall
-		Bool		     -- True <=> might cause GC
-		[HsType name] -- arg types, incl state token
-				     -- (which will be first)
-		(HsType name) -- return type
-
-  | UfOtherOp	name
+  | UfNote	(UfNote name) (UfExpr name)
+  | UfLit	Literal
+  | UfLitLit	FAST_STRING (HsType name)
+  | UfCCall	CCall (HsType name)
 
-data UfCoercion name = UfIn name | UfOut name
+data UfNote name = UfSCC CostCentre
+	         | UfCoerce (HsType name)
+	         | UfInlineCall
+	         | UfInlineMe
 
-data UfAlts name
-  = UfAlgAlts  [(name, [UfBinder name], UfExpr name)]
-		(UfDefault name)
-  | UfPrimAlts [(Literal, UfExpr name)]
-		(UfDefault name)
+type UfAlt name = (UfConAlt name, [name], UfExpr name)
 
-data UfDefault name
-  = UfNoDefault
-  | UfBindDefault (UfBinder name)
-		  (UfExpr name)
+data UfConAlt name = UfDefault
+ 		   | UfDataAlt name
+		   | UfLitAlt Literal
+		   | UfLitLitAlt FAST_STRING (HsType name)
 
 data UfBinding name
   = UfNonRec	(UfBinder name)
@@ -84,15 +75,9 @@ data UfBinding name
 data UfBinder name
   = UfValBinder	name (HsType name)
   | UfTyBinder	name Kind
-  | UfUsageBinder name
-
-data UfArg name
-  = UfVarArg	name
-  | UfLitArg	Literal
-  | UfTyArg	(HsType name)
-  | UfUsageArg	name
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection[HsCore-print]{Printing Core unfoldings}
@@ -101,72 +86,96 @@ data UfArg name
 
 \begin{code}
 instance Outputable name => Outputable (UfExpr name) where
-    ppr sty (UfVar v) = ppr sty v
-    ppr sty (UfLit l) = ppr sty l
+    ppr (UfVar v) = ppr v
+    ppr (UfLit l) = ppr l
 
-    ppr sty (UfCon c as)
-      = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"]
-    ppr sty (UfPrim o as)
-      = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"]
+    ppr (UfLitLit l ty) = ppr l
+    ppr (UfCCall cc ty) = pprCCallOp cc
 
-    ppr sty (UfLam b body)
-      = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body]
+    ppr (UfType ty) = char '@' <+> pprParendHsType ty
 
-    ppr sty (UfApp fun (UfTyArg ty))
-      = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty]
+    ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
 
-    ppr sty (UfApp fun (UfLitArg lit))
-      = ppCat [ppr sty fun, ppr sty lit]
+    ppr (UfLam b body)
+      = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
 
-    ppr sty (UfApp fun (UfVarArg var))
-      = ppCat [ppr sty fun, ppr sty var]
+    ppr (UfApp fun arg) = ppr fun <+> ppr arg 
 
-    ppr sty (UfCase scrut alts)
-      = ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
+    ppr (UfCase scrut bndr alts)
+      = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
+	      braces (hsep (punctuate semi (map pp_alt alts)))]
       where
-    	pp_alts (UfAlgAlts alts deflt)
-	  = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
-	  where
-	   pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
-    	pp_alts (UfPrimAlts alts deflt)
-	  = ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
-	  where
-	   pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
-
-	pp_deflt UfNoDefault = ppNil
-	pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
-
-    ppr sty (UfLet (UfNonRec b rhs) body)
-      = ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
-    ppr sty (UfLet (UfRec pairs) body)
-      = ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
-      where
-	pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
+	pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
 
-    ppr sty (UfSCC uf_cc body)
-      = ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
+        ppr_arrow = ptext SLIT("->")
 
-instance Outputable name => Outputable (UfPrimOp name) where
-    ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
-      = let
-	    before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
-	    after  = if is_casm then ppStr "'' " else ppSP
-	in
-	ppBesides [before, ppPStr str, after,
-		  ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+    ppr (UfLet (UfNonRec b rhs) body)
+      = hsep [ptext SLIT("let"), ppr b, equals, ppr rhs, ptext SLIT("in"), ppr body]
+    ppr (UfLet (UfRec pairs) body)
+      = hsep [ptext SLIT("letrec"), braces (hsep (punctuate semi (map pp_pair pairs))), ptext SLIT("in"), ppr body]
+      where
+	pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
 
-    ppr sty (UfOtherOp op)
-      = ppr sty op
+    ppr (UfNote note body)
+      = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
 
-instance Outputable name => Outputable (UfArg name) where
-    ppr sty (UfVarArg v)	= ppr sty v
-    ppr sty (UfLitArg l)	= ppr sty l
-    ppr sty (UfTyArg ty)	= pprParendHsType sty ty
-    ppr sty (UfUsageArg name)	= ppr sty name
+instance Outputable name => Outputable (UfConAlt name) where
+    ppr UfDefault	   = text "DEFAULT"
+    ppr (UfLitAlt l)       = ppr l
+    ppr (UfLitLitAlt l ty) = ppr l
+    ppr (UfDataAlt d)	   = ppr d
 
 instance Outputable name => Outputable (UfBinder name) where
-    ppr sty (UfValBinder name ty)  = ppCat [ppr sty name, ppStr "::", ppr sty ty]
-    ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
-    ppr sty (UfUsageBinder name)   = ppr sty name
+    ppr (UfValBinder name ty)  = hsep [ppr name, dcolon, ppr ty]
+    ppr (UfTyBinder name kind) = hsep [ppr name, dcolon, ppr kind]
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Signatures in interface files}
+%*									*
+%************************************************************************
+
+\begin{code}
+data IfaceSig name
+  = IfaceSig	name
+		(HsType name)
+		[HsIdInfo name]
+		SrcLoc
+
+instance (Outputable name) => Outputable (IfaceSig name) where
+    ppr (IfaceSig var ty info _)
+      = hang (hsep [ppr var, dcolon])
+	     4 (ppr ty $$ ifPprDebug (vcat (map ppr info)))
+
+data HsIdInfo name
+  = HsArity		ArityInfo
+  | HsStrictness	HsStrictnessInfo
+  | HsUnfold		InlinePragInfo (UfExpr name)
+  | HsUpdate		UpdateInfo
+  | HsSpecialise	(UfRuleBody name)
+  | HsNoCafRefs
+  | HsCprInfo
+  | HsWorker		name		-- Worker, if any
+
+instance Outputable name => Outputable (HsIdInfo name) where
+  ppr (HsUnfold _ unf) = ptext (SLIT("Unfolding:")) <+> ppr unf
+  ppr other	       = empty	-- Havn't got around to this yet
+
+data HsStrictnessInfo
+  = HsStrictnessInfo ([Demand], Bool)
+  | HsBottom
+\end{code}
+
+ 
+%************************************************************************
+%*									*
+\subsection{Rules in interface files}
+%*									*
+%************************************************************************
+
+\begin{code}
+data UfRuleBody name = UfRuleBody   FAST_STRING [UfBinder name] [UfExpr name] (UfExpr name)	-- Pre typecheck
+		     | CoreRuleBody FAST_STRING [CoreBndr]      [CoreExpr]    CoreExpr		-- Post typecheck
+\end{code}