X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=a70706862be1d2d54f51716126da67e1e140bc7d;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=3ed0d380905764fd2e22bd6da56d028db77fa8aa;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 3ed0d38..a707068 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -15,7 +15,7 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program.
 
 module CoreToStg ( topCoreBindsToStg ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import CoreSyn		-- input
 import StgSyn		-- output
@@ -29,17 +29,24 @@ import Id		( mkSysLocal, idType, isBottomingId,
 			)
 import Literal		( mkMachInt, Literal(..) )
 import Name		( isExported )
-import PrelInfo		( unpackCStringId, unpackCString2Id, stringTy,
-			  integerTy, rationalTy, ratioDataCon,
+import PrelVals		( unpackCStringId, unpackCString2Id,
 			  integerZeroId, integerPlusOneId,
 			  integerPlusTwoId, integerMinusOneId
 			)
 import PrimOp		( PrimOp(..) )
 import SpecUtils	( mkSpecialisedCon )
 import SrcLoc		( mkUnknownSrcLoc )
-import Type		( getAppDataTyConExpandingDicts )
+import TyCon		( TyCon{-instance Uniquable-} )
+import Type		( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
+import TysWiredIn	( stringTy )
+import Unique		( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
 import UniqSupply	-- all of it, really
-import Util		( panic )
+import Util		( panic, assertPanic, pprTrace{-ToDo:rm-} )
+import Pretty--ToDo:rm
+import PprStyle--ToDo:rm
+import PprType  --ToDo:rm
+import Outputable--ToDo:rm
+import PprEnv--ToDo:rm
 
 isLeakFreeType x y = False -- safe option; ToDo
 \end{code}
@@ -303,7 +310,7 @@ litToStgArg (NoRepStr s)
   where
     is_NUL c = c == '\0'
 
-litToStgArg (NoRepInteger i)
+litToStgArg (NoRepInteger i integer_ty)
   -- extremely convenient to look out for a few very common
   -- Integer literals!
   | i == 0    = returnUs (StgVarArg integerZeroId,     emptyBag)
@@ -312,7 +319,7 @@ litToStgArg (NoRepInteger i)
   | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
 
   | otherwise
-  = newStgVar integerTy 		`thenUs` \ var ->
+  = newStgVar integer_ty	`thenUs` \ var ->
     let
 	rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
 			    stgArgOcc	 -- safe
@@ -332,18 +339,33 @@ litToStgArg (NoRepInteger i)
     in
     returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
 
-litToStgArg (NoRepRational r)
- = litToStgArg (NoRepInteger (numerator   r))	`thenUs` \ (num_atom,   binds1) ->
-   litToStgArg (NoRepInteger (denominator r))	`thenUs` \ (denom_atom, binds2) ->
-   newStgVar rationalTy			`thenUs` \ var ->
-   let
-	rhs = StgRhsCon noCostCentre	-- No cost centre (ToDo?)
-			ratioDataCon	-- Constructor
-			[num_atom, denom_atom]
-   in
-   returnUs (StgVarArg var, binds1 `unionBags`
-			   binds2 `unionBags`
-			   unitBag (StgNonRec var rhs))
+litToStgArg (NoRepRational r rational_ty)
+  = --ASSERT(is_rational_ty)
+    (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
+    litToStgArg (NoRepInteger (numerator   r) integer_ty) `thenUs` \ (num_atom,   binds1) ->
+    litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
+    newStgVar rational_ty			`thenUs` \ var ->
+    let
+	 rhs = StgRhsCon noCostCentre	-- No cost centre (ToDo?)
+			 ratio_data_con	-- Constructor
+			 [num_atom, denom_atom]
+    in
+    returnUs (StgVarArg var, binds1 `unionBags`
+			    binds2 `unionBags`
+			    unitBag (StgNonRec var rhs))
+  where
+    (is_rational_ty, ratio_data_con, integer_ty)
+      = case (maybeAppDataTyCon rational_ty) of
+	  Just (tycon, [i_ty], [con])
+	    -> ASSERT(is_integer_ty i_ty)
+	       (uniqueOf tycon == ratioTyConKey, con, i_ty)
+
+	  _ -> (False, panic "ratio_data_con", panic "integer_ty")
+
+    is_integer_ty ty
+      = case (maybeAppDataTyCon ty) of
+	  Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
+	  _ -> False
 
 litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
 \end{code}
@@ -426,17 +448,21 @@ coreExprToStg env expr@(Lam _ _)
   = let
 	(_,_, binders, body) = collectBinders expr
     in
-    coreExprToStg env body		`thenUs` \ (stg_body, binds) ->
-    newStgVar (coreExprType expr)	`thenUs` \ var ->
-    returnUs
-      (StgLet (StgNonRec var (StgRhsClosure noCostCentre
-		 	      stgArgOcc
-			      bOGUS_FVs
-			      ReEntrant 	-- binders is non-empty
-			      binders
-			      stg_body))
-       (StgApp (StgVarArg var) [] bOGUS_LVs),
-       binds)
+    coreExprToStg env body		`thenUs` \ stuff@(stg_body, binds) ->
+
+    if null binders then -- it was all type/usage binders; tossed
+	returnUs stuff
+    else
+	newStgVar (coreExprType expr)	`thenUs` \ var ->
+	returnUs
+	  (StgLet (StgNonRec var (StgRhsClosure noCostCentre
+				  stgArgOcc
+				  bOGUS_FVs
+				  ReEntrant 	-- binders is non-empty
+				  binders
+				  stg_body))
+	   (StgApp (StgVarArg var) [] bOGUS_LVs),
+	   binds)
 \end{code}
 
 %************************************************************************