mkSimpleMatch
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
- TypecheckedStmt,
- maybeBoxedPrimType
-
+ TypecheckedStmt
)
import CoreSyn
+import PprCore ( {- instance Outputable Expr -} )
+import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
import DsMonad
-import DsBinds ( dsMonoBinds )
+import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsGRHSs ( dsGuarded )
-import DsCCall ( dsCCall )
+import DsCCall ( dsCCall, resultWrapper )
import DsListComp ( dsListComp )
-import DsUtils ( mkErrorAppDs )
+import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
import Match ( matchWrapper, matchSimply )
-import CoreUtils ( coreExprType )
import CostCentre ( mkUserCC )
import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
-import Const ( Con(..) )
-import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
-import Const ( mkMachInt, Literal(..), mkStrLit )
-import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import DataCon ( DataCon, dataConWrapId, dataConTyCon, dataConArgTys, dataConFieldLabels )
+import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, addr2IntegerId )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
+import Literal ( Literal(..), inIntRange )
import Type ( splitFunTys, mkTyConApp,
- splitAlgTyConApp, splitTyConApp_maybe,
+ splitAlgTyConApp, splitAlgTyConApp_maybe, splitTyConApp_maybe,
+ isNotUsgTy, unUsgTy,
splitAppTy, isUnLiftedType, Type
)
import TysWiredIn ( tupleCon, unboxedTupleCon,
- consDataCon, listTyCon, mkListTy,
- charDataCon, charTy, stringTy
+ listTyCon, mkListTy,
+ charDataCon, charTy, stringTy,
+ smallIntegerDataCon, isIntegerTy
)
import BasicTypes ( RecFlag(..) )
import Maybes ( maybeToBool )
+import Unique ( Uniquable(..), ratioTyConKey )
import Util ( zipEqual, zipWithEqual )
import Outputable
+
+import Ratio ( numerator, denominator )
\end{code}
%* *
%************************************************************************
-@dsLet@ is a match-result transformer, taking the MatchResult for the body
+@dsLet@ is a match-result transformer, taking the @MatchResult@ for the body
and transforming it into one for the let-bindings enclosing the body.
This may seem a bit odd, but (source) let bindings can contain unboxed
binds like
-
+\begin{verbatim}
C x# = e
-
+\end{verbatim}
This must be transformed to a case expression and, if the type has
more than one constructor, may fail.
dsLet b1 body'
-- Special case for bindings which bind unlifted variables
-dsLet (MonoBind (AbsBinds [] [] binder_triples (PatMonoBind pat grhss loc)) sigs is_rec) body
+-- 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]
= ASSERT (case is_rec of {NonRecursive -> True; other -> False})
putSrcLocDs loc $
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 ->
+ mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat))
+ `thenDs` \ error_expr ->
matchSimply rhs PatBindMatch pat body' error_expr
where
- result_ty = coreExprType body
+ result_ty = exprType body
-- Ordinary case for bindings
dsLet (MonoBind binds sigs is_rec) body
- = dsMonoBinds False binds [] `thenDs` \ prs ->
+ = dsMonoBinds NoSccs binds [] `thenDs` \ prs ->
case is_rec of
Recursive -> returnDs (Let (Rec prs) body)
- NonRecursive -> returnDs (foldr mk_let body prs)
- where
- mk_let (bndr,rhs) body = Let (NonRec bndr rhs) body
+ NonRecursive -> returnDs (mkDsLets [NonRec b r | (b,r) <- prs] body)
\end{code}
%************************************************************************
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
dsExpr e@(HsVar var) = returnDs (Var var)
+dsExpr e@(HsIPVar var) = returnDs (Var var)
\end{code}
%************************************************************************
%* *
%************************************************************************
-We give int/float literals type Integer and Rational, respectively.
+We give int/float literals type @Integer@ and @Rational@, respectively.
The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
around them.
-ToDo: put in range checks for when converting "i"
+ToDo: put in range checks for when converting ``@i@''
(or should that be in the typechecker?)
For numeric literals, we try to detect there use at a standard type
-(Int, Float, etc.) are directly put in the right constructor.
+(@Int@, @Float@, etc.) are directly put in the right constructor.
[NB: down with the @App@ conversion.]
-Otherwise, we punt, putting in a "NoRep" Core literal (where the
-representation decisions are delayed)...
See also below where we look for @DictApps@ for \tr{plusInt}, etc.
= let
the_char = mkConApp charDataCon [mkLit (MachChar (_HEAD_ s))]
the_nil = mkNilExpr charTy
- the_cons = mkConApp consDataCon [Type charTy, the_char, the_nil]
+ the_cons = mkConsExpr charTy the_char the_nil
in
returnDs the_cons
-- "_" => build (\ c n -> c 'c' n) -- LATER
--- "str" ==> build (\ c n -> foldr charTy T c n "str")
-
-{- LATER:
dsExpr (HsLitOut (HsString str) _)
- = newTyVarsDs [alphaTyVar] `thenDs` \ [new_tyvar] ->
- let
- new_ty = mkTyVarTy new_tyvar
- in
- newSysLocalsDs [
- charTy `mkFunTy` (new_ty `mkFunTy` new_ty),
- new_ty,
- mkForallTy [alphaTyVar]
- ((charTy `mkFunTy` (alphaTy `mkFunTy` alphaTy))
- `mkFunTy` (alphaTy `mkFunTy` alphaTy))
- ] `thenDs` \ [c,n,g] ->
- returnDs (mkBuild charTy new_tyvar c n g (
- foldl App
- (CoTyApp (CoTyApp (Var foldrId) charTy) new_ty) *** ensure non-prim type ***
- [VarArg c,VarArg n,LitArg (NoRepStr str)]))
--}
-
--- otherwise, leave it as a NoRepStr;
--- the Core-to-STG pass will wrap it in an application of "unpackCStringId".
-
-dsExpr (HsLitOut (HsString str) _)
- = returnDs (mkLit (NoRepStr str stringTy))
+ = returnDs (mkStringLitFS str)
dsExpr (HsLitOut (HsLitLit str) ty)
- = case (maybeBoxedPrimType ty) of
- Just (boxing_data_con, prim_ty) ->
- returnDs ( mkConApp boxing_data_con [mkLit (MachLitLit str prim_ty)] )
- _ ->
- pprError "ERROR:"
- (vcat
- [ hcat [ text "Cannot see data constructor of ``literal-literal''s type: "
- , text "value:", quotes (quotes (ptext str))
- , text "; type: ", ppr ty
- ]
- , text "Try compiling with -fno-prune-tydecls."
- ])
-
+ = ASSERT( maybeToBool maybe_ty )
+ returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
where
- (data_con, prim_ty)
- = case (maybeBoxedPrimType ty) of
- Just (boxing_data_con, prim_ty) -> (boxing_data_con, prim_ty)
- Nothing
- -> pprPanic "ERROR: ``literal-literal'' not a single-constructor type: "
- (hcat [ptext str, text "; type: ", ppr ty])
+ (maybe_ty, wrap_fn) = resultWrapper ty
+ Just rep_ty = maybe_ty
dsExpr (HsLitOut (HsInt i) ty)
- = returnDs (mkLit (NoRepInteger i ty))
+ = returnDs (mkIntegerLit i)
+
dsExpr (HsLitOut (HsFrac r) ty)
- = returnDs (mkLit (NoRepRational r ty))
+ = returnDs (mkConApp ratio_data_con [Type integer_ty,
+ mkIntegerLit (numerator r),
+ mkIntegerLit (denominator r)])
+ where
+ (ratio_data_con, integer_ty)
+ = case (splitAlgTyConApp_maybe ty) of
+ Just (tycon, [i_ty], [con])
+ -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
+ (con, i_ty)
+
+ _ -> (panic "ratio_data_con", panic "integer_ty")
+
+
-- others where we know what to do:
-dsExpr (HsLitOut (HsIntPrim i) _)
- | (i >= toInteger minInt && i <= toInteger maxInt)
- = returnDs (mkLit (mkMachInt i))
- | otherwise
- = error ("ERROR: Int constant " ++ show i ++ out_of_range_msg)
+dsExpr (HsLitOut (HsIntPrim i) _)
+ = returnDs (mkIntLit i)
dsExpr (HsLitOut (HsFloatPrim f) _)
= returnDs (mkLit (MachFloat f))
- -- ToDo: range checking needed!
dsExpr (HsLitOut (HsDoublePrim d) _)
= returnDs (mkLit (MachDouble d))
dsExpr (OpApp e1 op _ e2)
= dsExpr op `thenDs` \ core_op ->
-- for the type of y, we need the type of op's 2nd argument
- let
- (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
- in
dsExpr e1 `thenDs` \ x_core ->
dsExpr e2 `thenDs` \ y_core ->
returnDs (mkApps core_op [x_core, y_core])
= dsExpr op `thenDs` \ core_op ->
-- for the type of y, we need the type of op's 2nd argument
let
- (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
in
dsExpr expr `thenDs` \ x_core ->
newSysLocalDs x_ty `thenDs` \ x_id ->
= dsExpr op `thenDs` \ core_op ->
-- for the type of x, we need the type of op's 2nd argument
let
- (x_ty:y_ty:_, _) = splitFunTys (coreExprType core_op)
+ (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
in
dsExpr expr `thenDs` \ y_core ->
newSysLocalDs x_ty `thenDs` \ x_id ->
returnDs (bindNonRec y_id y_core $
Lam x_id (mkApps core_op [Var x_id, Var y_id]))
-dsExpr (CCall label args may_gc is_asm result_ty)
+dsExpr (HsCCall lbl args may_gc is_asm result_ty)
= mapDs dsExpr args `thenDs` \ core_args ->
- dsCCall label core_args may_gc is_asm result_ty
+ dsCCall lbl core_args may_gc is_asm result_ty
-- dsCCall does all the unboxification, etc.
dsExpr (HsSCC cc expr)
= dsExpr expr `thenDs` \ core_expr ->
- getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
- returnDs (Note (SCC (mkUserCC cc mod_name group_name)) core_expr)
+ getModuleDs `thenDs` \ mod_name ->
+ returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr)
-- special case to handle unboxed tuple patterns.
-dsExpr (HsCase discrim matches@[Match _ [TuplePat ps boxed] _ _] src_loc)
- | not boxed && all var_pat ps
+dsExpr (HsCase discrim matches src_loc)
+ | all ubx_tuple_match matches
= putSrcLocDs src_loc $
- dsExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
case matching_code of
Case (Var x) bndr alts | x == discrim_var ->
returnDs (Case core_discrim bndr alts)
_ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
+ where
+ ubx_tuple_match (Match _ [TuplePat ps False{-unboxed-}] _ _) = True
+ ubx_tuple_match _ = False
dsExpr (HsCase discrim matches src_loc)
= putSrcLocDs src_loc $
- dsExpr discrim `thenDs` \ core_discrim ->
- matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
+ dsExpr discrim `thenDs` \ core_discrim ->
+ matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
= dsExpr body `thenDs` \ body' ->
dsLet binds body'
-
+
+dsExpr (HsWith expr binds)
+ = dsExpr expr `thenDs` \ expr' ->
+ foldlDs dsIPBind expr' binds
+ where
+ dsIPBind body (n, e)
+ = dsExpr e `thenDs` \ e' ->
+ returnDs (Let (NonRec n e') body)
+
dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
| maybeToBool maybe_list_comp
= -- Special case for list comprehensions
\end{code}
-Type lambda and application
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\noindent
+\underline{\bf Type lambda and application}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
dsExpr (TyLam tyvars expr)
= dsExpr expr `thenDs` \ core_expr ->
\end{code}
-Various data construction things
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\noindent
+\underline{\bf Various data construction things}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
dsExpr (ExplicitListOut ty xs)
= go xs
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
- returnDs (mkConApp consDataCon [Type ty, core_x, core_xs])
+ ASSERT( isNotUsgTy ty )
+ returnDs (mkConsExpr ty core_x core_xs)
dsExpr (ExplicitTuple expr_list boxed)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
returnDs (mkConApp ((if boxed
then tupleCon
else unboxedTupleCon) (length expr_list))
- (map (Type . coreExprType) core_exprs ++ core_exprs))
-
-dsExpr (HsCon con_id [ty] [arg])
- | isNewTyCon tycon
- = dsExpr arg `thenDs` \ arg' ->
- returnDs (Note (Coerce result_ty (coreExprType arg')) arg')
- where
- result_ty = mkTyConApp tycon [ty]
- tycon = dataConTyCon con_id
-
-dsExpr (HsCon con_id tys args)
- = mapDs dsExpr args `thenDs` \ args2 ->
- returnDs (mkConApp con_id (map Type tys ++ args2))
+ (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs))
+ -- the above unUsgTy is *required* -- KSW 1999-04-07
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
returnDs (mkApps expr2 [from2, thn2, two2])
\end{code}
-Record construction and update
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\noindent
+\underline{\bf Record construction and update}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For record construction we do this (assuming T has three arguments)
-
+\begin{verbatim}
T { op2 = e }
==>
let err = /\a -> recConErr a
T (recConErr t1 "M.lhs/230/op1")
e
(recConErr t1 "M.lhs/230/op3")
-
-recConErr then converts its arugment string into a proper message
+\end{verbatim}
+@recConErr@ then converts its arugment string into a proper message
before printing it as
-
+\begin{verbatim}
M.lhs, line 230: missing field op1 was evaluated
+\end{verbatim}
+We also handle @C{}@ as valid construction syntax for an unlabelled
+constructor @C@, setting all of @C@'s fields to bottom.
\begin{code}
dsExpr (RecordConOut data_con con_expr rbinds)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
- (arg_tys, _) = splitFunTys (coreExprType con_expr')
+ (arg_tys, _) = splitFunTys (exprType con_expr')
mk_arg (arg_ty, lbl)
= case [rhs | (sel_id,rhs,_) <- rbinds,
(rhs:rhss) -> ASSERT( null rhss )
dsExpr rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
+ unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty ""
+
+ labels = dataConFieldLabels data_con
in
- mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys (dataConFieldLabels data_con)) `thenDs` \ con_args ->
+
+ (if null labels
+ then mapDs unlabelled_bottom arg_tys
+ else mapDs mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels))
+ `thenDs` \ con_args ->
+
returnDs (mkApps con_expr' con_args)
\end{code}
Record update is a little harder. Suppose we have the decl:
-
+\begin{verbatim}
data T = T1 {op1, op2, op3 :: Int}
| T2 {op4, op2 :: Int}
| T3
-
+\end{verbatim}
Then we translate as follows:
-
+\begin{verbatim}
r { op2 = e }
===>
let op2 = e in
T1 op1 _ op3 -> T1 op1 op2 op3
T2 op4 _ -> T2 op4 op2
other -> recUpdError "M.lhs/230"
-
-It's important that we use the constructor Ids for T1, T2 etc on the
-RHSs, and do not generate a Core Con directly, because the constructor
+\end{verbatim}
+It's important that we use the constructor Ids for @T1@, @T2@ etc on the
+RHSs, and do not generate a Core constructor application directly, because the constructor
might do some argument-evaluation first; and may have to throw away some
dictionaries.
\begin{code}
dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
- = dsExpr record_expr `thenDs` \ record_expr' ->
+ = getSrcLocDs `thenDs` \ src_loc ->
+ dsExpr record_expr `thenDs` \ record_expr' ->
-- Desugar the rbinds, and generate let-bindings if
-- necessary so that we don't lose sharing
let
- ds_rbind (sel_id, rhs, pun_flag)
- = dsExpr rhs `thenDs` \ rhs' ->
- returnDs (recordSelectorFieldLabel sel_id, rhs')
- in
- mapDs ds_rbind rbinds `thenDs` \ rbinds' ->
- let
- record_in_ty = coreExprType record_expr'
+ record_in_ty = exprType record_expr'
(tycon, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
(_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
cons_to_upd = filter has_all_fields cons
- -- initial_args are passed to every constructor
- initial_args = map Type out_inst_tys ++ map Var dicts
-
mk_val_arg field old_arg_id
- = case [rhs | (f, rhs) <- rbinds', field == f] of
+ = case [rhs | (sel_id, rhs, _) <- rbinds,
+ field == recordSelectorFieldLabel sel_id] of
(rhs:rest) -> ASSERT(null rest) rhs
- [] -> Var old_arg_id
+ [] -> HsVar old_arg_id
mk_alt con
= newSysLocalsDs (dataConArgTys con in_inst_tys) `thenDs` \ arg_ids ->
+ -- This call to dataConArgTys won't work for existentials
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
- rhs = mkApps (mkApps (Var (dataConId con)) initial_args) val_args
+ rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConWrapId con))
+ out_inst_tys)
+ dicts)
+ val_args
in
- returnDs (DataCon con, arg_ids, rhs)
-
- mk_default
- | length cons_to_upd == length cons
- = returnDs []
- | otherwise
- = mkErrorAppDs rEC_UPD_ERROR_ID record_out_ty "" `thenDs` \ err ->
- returnDs [(DEFAULT, [], err)]
+ returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)]
+ rhs
+ (Just record_out_ty)
+ src_loc)
in
-- Record stuff doesn't work for existentials
ASSERT( all (not . isExistentialDataCon) cons )
- newSysLocalDs record_in_ty `thenDs` \ case_bndr ->
- mapDs mk_alt cons_to_upd `thenDs` \ alts ->
- mk_default `thenDs` \ deflt ->
+ -- It's important to generate the match with matchWrapper,
+ -- and the right hand sides with applications of the wrapper Id
+ -- so that everything works when we are doing fancy unboxing on the
+ -- constructor aguments.
+ mapDs mk_alt cons_to_upd `thenDs` \ alts ->
+ matchWrapper RecUpdMatch alts "record update" `thenDs` \ ([discrim_var], matching_code) ->
+
+ returnDs (bindNonRec discrim_var record_expr' matching_code)
- returnDs (Case record_expr' case_bndr (alts ++ deflt))
where
has_all_fields :: DataCon -> Bool
has_all_fields con_id
ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields
\end{code}
-Dictionary lambda and application
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+\noindent
+\underline{\bf Dictionary lambda and application}
+% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@DictLam@ and @DictApp@ turn into the regular old things.
(OLD:) @DictFunApp@ also becomes a curried application, albeit slightly more
complicated; reminiscent of fully-applied constructors.
dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
#endif
-out_of_range_msg -- ditto
- = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n"
\end{code}
%--------------------------------------------------------------------
go (GuardStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
- let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
+ let msg = ASSERT( isNotUsgTy b_ty )
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
returnDs (mkIfThenElse expr2
rest
(App (App (Var fail_id)
(Type b_ty))
- (mkLit (mkStrLit msg stringTy))))
+ (mkStringLit msg)))
go (ExprStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
let
- (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
+ (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a)
in
if null stmts then
returnDs expr2
= putSrcLocDs locn $
dsExpr expr `thenDs` \ expr2 ->
let
- (_, a_ty) = splitAppTy (coreExprType expr2) -- Must be of form (m a)
- fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLitOut (HsString (_PK_ msg)) stringTy)
- msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a)
+ fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty])
+ (HsLitOut (HsString (_PK_ msg)) stringTy)
+ msg = ASSERT2( isNotUsgTy a_ty, ppr a_ty )
+ ASSERT2( isNotUsgTy b_ty, ppr b_ty )
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
main_match = mkSimpleMatch [pat]
- (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty locn)
+ (HsDoOut do_or_lc stmts return_id then_id
+ fail_id result_ty locn)
(Just result_ty) locn
the_matches
| failureFreePat pat = [main_match]
var_pat _ = False
\end{code}
+\begin{code}
+mkIntegerLit :: Integer -> CoreExpr
+mkIntegerLit i
+ | inIntRange i -- Small enough, so start from an Int
+ = mkConApp smallIntegerDataCon [mkIntLit i]
+
+ | otherwise -- Big, so start from a string
+ = App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i))))
+\end{code}
+