[project @ 2002-01-30 12:13:59 by simonmar]

[ghc-hetmet.git] / ghc / compiler / deSugar / DsExpr.lhs

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index c14935a..162ae24 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -47,7 +47,7 @@ import DataCon                ( isExistentialDataCon )
 import Literal         ( Literal(..) )
 import TyCon           ( tyConDataCons )
 import TysWiredIn      ( tupleCon, listTyCon, charDataCon, intDataCon )
-import BasicTypes      ( RecFlag(..), Boxity(..) )
+import BasicTypes      ( RecFlag(..), Boxity(..), ipNameName )
 import Maybes          ( maybeToBool )
 import PrelNames       ( hasKey, ratioTyConKey )
 import Util            ( zipEqual, zipWithEqual )
@@ -85,23 +85,40 @@ dsLet (ThenBinds b1 b2) body
     dsLet b1 body'
   
 -- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
 -- Silently ignore INLINE pragmas...
-dsLet (MonoBind (AbsBinds [] [] binder_triples inlines
-                          (PatMonoBind pat grhss loc)) sigs is_rec) body
-  | or [isUnLiftedType (idType g) | (_, g, l) <- binder_triples]
+dsLet bind@(MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body
+  | or [isUnLiftedType (idType g) | (_, g, l) <- exports]
   = ASSERT (case is_rec of {NonRecursive -> True; other -> False})
-    putSrcLocDs loc                    $
-    dsGuarded grhss                    `thenDs` \ rhs ->
-    let
-       body' = foldr bind body binder_triples
-       bind (tyvars, g, l) body = ASSERT( null tyvars )
-                                  bindNonRec g (Var l) body
-    in
-    mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat))
-    `thenDs` \ error_expr ->
-    matchSimply rhs PatBindRhs pat body' error_expr
+       -- Unlifted bindings are always non-recursive
+       -- and are always a Fun or Pat monobind
+       --
+       -- ToDo: in some bizarre case it's conceivable that there
+       --       could be dict binds in the 'binds'.  (See the notes
+       --       below.  Then pattern-match would fail.  Urk.)
+    case binds of
+      FunMonoBind fun _ matches loc
+       -> putSrcLocDs loc                      $
+          matchWrapper (FunRhs fun) matches    `thenDs` \ (args, rhs) ->
+          ASSERT( null args )  -- Functions aren't lifted
+          returnDs (bindNonRec fun rhs body_w_exports)
+
+      PatMonoBind pat grhss loc
+       -> putSrcLocDs loc                      $
+          dsGuarded grhss                      `thenDs` \ rhs ->
+          mk_error_app pat                     `thenDs` \ error_expr ->
+          matchSimply rhs PatBindRhs pat body_w_exports error_expr
+
+      other -> pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
   where
-    result_ty = exprType body
+    body_w_exports              = foldr bind_export body exports
+    bind_export (tvs, g, l) body = ASSERT( null tvs )
+                                  bindNonRec g (Var l) body
+
+    mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
+                                   (exprType body)
+                                   (showSDoc (ppr pat))
 
 -- Ordinary case for bindings
 dsLet (MonoBind binds sigs is_rec) body
@@ -114,7 +131,10 @@ dsLet (MonoBind binds sigs is_rec) body
        --         but which does have dictionary bindings.
        -- See notes with TcSimplify.inferLoop [NO TYVARS]
        -- It turned out that wrapping a Rec here was the easiest solution
-\end{code}
+       --
+       -- NB The previous case dealt with unlifted bindings, so we
+       --    only have to deal with lifted ones now; so Rec is ok
+\end{code}     
 
 %************************************************************************
 %*                                                                     *
@@ -125,9 +145,9 @@ dsLet (MonoBind binds sigs is_rec) body
 \begin{code}
 dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
 
-dsExpr (HsVar var)      = returnDs (Var var)
-dsExpr (HsIPVar var)     = returnDs (Var var)
-dsExpr (HsLit lit)       = dsLit lit
+dsExpr (HsVar var)  = returnDs (Var var)
+dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip))
+dsExpr (HsLit lit)  = dsLit lit
 -- HsOverLit has been gotten rid of by the type checker
 
 dsExpr expr@(HsLam a_Match)
@@ -221,7 +241,7 @@ dsExpr (HsCase discrim matches src_loc)
                returnDs (Case core_discrim bndr alts)
        _ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
   where
-    ubx_tuple_match (Match _ [TuplePat ps Unboxed] _ _) = True
+    ubx_tuple_match (Match [TuplePat ps Unboxed] _ _) = True
     ubx_tuple_match _ = False
 
 dsExpr (HsCase discrim matches src_loc)
@@ -240,7 +260,7 @@ dsExpr (HsWith expr binds)
     where
       dsIPBind body (n, e)
         = dsExpr e     `thenDs` \ e' ->
-         returnDs (Let (NonRec n e') body)
+         returnDs (Let (NonRec (ipNameName n) e') body)
 
 dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
   | maybeToBool maybe_list_comp
@@ -625,6 +645,3 @@ dsLit (HsRat r ty)
                (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
                                   (head (tyConDataCons tycon), i_ty)
 \end{code}
-
-
-