[project @ 1996-07-19 18:36:04 by partain]

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

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index a707068..114131a 100644 (file)
--- 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}