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

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index a707068..114131a 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -9,13 +9,13 @@
 
 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
 
-
 \begin{code}
 #include "HsVersions.h"
 
 module CoreToStg ( topCoreBindsToStg ) where
 
 IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio(numerator,denominator))
 
 import CoreSyn		-- input
 import StgSyn		-- output
@@ -24,11 +24,11 @@ import Bag		( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
 import CoreUtils	( coreExprType )
 import CostCentre	( noCostCentre )
 import Id		( mkSysLocal, idType, isBottomingId,
+			  externallyVisibleId,
 			  nullIdEnv, addOneToIdEnv, lookupIdEnv,
-			  IdEnv(..), GenId{-instance NamedThing-}
+			  SYN_IE(IdEnv), GenId{-instance NamedThing-}
 			)
 import Literal		( mkMachInt, Literal(..) )
-import Name		( isExported )
 import PrelVals		( unpackCStringId, unpackCString2Id,
 			  integerZeroId, integerPlusOneId,
 			  integerPlusTwoId, integerMinusOneId
@@ -41,12 +41,12 @@ import Type		( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
 import TysWiredIn	( stringTy )
 import Unique		( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
 import UniqSupply	-- all of it, really
-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
+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}
@@ -197,9 +197,11 @@ coreBindToStg env (NonRec binder rhs)
 
     let
 	-- Binds to return if RHS is trivial
-	triv_binds = if isExported binder then
+	triv_binds = if externallyVisibleId binder then
+			-- pprTrace "coreBindToStg:keeping:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $
 			[StgNonRec binder stg_rhs]	-- Retain it
 		     else
+			-- pprTrace "coreBindToStg:tossing:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $
 			[]				-- Discard it
     in
     case stg_rhs of
@@ -341,7 +343,7 @@ litToStgArg (NoRepInteger i integer_ty)
 
 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)) $
+    --(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 ->
@@ -474,14 +476,19 @@ coreExprToStg env expr@(Lam _ _)
 \begin{code}
 coreExprToStg env expr@(App _ _)
   = let
-	(fun, _, _, args) = collectArgs expr
+	(fun,args) = collect_args expr []
     in
 	-- Deal with the arguments
     coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
 
 	-- Now deal with the function
-    case fun of
-      Var fun_id -> returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+    case (fun, args) of
+      (Var fun_id, _) -> 	-- A function Id, so do an StgApp; it's ok if
+				-- there are no arguments.
+			    returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+
+      (non_var_fun, []) -> 	-- No value args, so recurse into the function
+			    coreExprToStg env non_var_fun
 
       other ->	-- A non-variable applied to things; better let-bind it.
 		newStgVar (coreExprType fun)	`thenUs` \ fun_id ->
@@ -497,6 +504,12 @@ coreExprToStg env expr@(App _ _)
 		returnUs (StgLet (StgNonRec fun_id fun_rhs)
 			   	  (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
 			   arg_binds `unionBags` fun_binds)
+  where
+	-- Collect arguments, discarding type/usage applications
+    collect_args (App e   (TyArg _))    args = collect_args e   args
+    collect_args (App e   (UsageArg _)) args = collect_args e   args
+    collect_args (App fun arg)          args = collect_args fun (arg:args)
+    collect_args fun                    args = (fun, args)
 \end{code}
 
 %************************************************************************
@@ -644,9 +657,7 @@ coreExprToStg env (SCC cc expr)
 \end{code}
 
 \begin{code}
-coreExprToStg env (Coerce c ty expr)
-  = coreExprToStg env expr  -- `thenUs` \ (stg_expr, binds) ->
---  returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
+coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
 \end{code}