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, AutoScc(..) )
import DsGRHSs ( dsGuarded )
-import DsCCall ( dsCCall )
+import DsCCall ( dsCCall, resultWrapper )
import DsListComp ( dsListComp )
-import DsUtils ( mkErrorAppDs, mkDsLets, mkConsExpr, mkNilExpr )
+import DsUtils ( mkErrorAppDs, mkDsLets, mkStringLit, mkStringLitFS,
+ mkConsExpr, mkNilExpr
+ )
import Match ( matchWrapper, matchSimply )
-import CoreUtils ( exprType )
import CostCentre ( mkUserCC )
import FieldLabel ( FieldLabel )
import Id ( Id, idType, recordSelectorFieldLabel )
-import DataCon ( DataCon, dataConId, dataConTyCon, dataConArgTys, dataConFieldLabels )
-import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID, addr2IntegerId )
+import PrelInfo ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, iRREFUT_PAT_ERROR_ID )
+import DataCon ( DataCon, dataConWrapId, dataConTyCon, dataConArgTys, dataConFieldLabels )
import TyCon ( isNewTyCon )
import DataCon ( isExistentialDataCon )
import Literal ( Literal(..), inIntRange )
isNotUsgTy, unUsgTy,
splitAppTy, isUnLiftedType, Type
)
-import PprType ( {- instance Outputable Type -} )
-import TysWiredIn ( tupleCon, unboxedTupleCon,
+import TysWiredIn ( tupleCon,
listTyCon, mkListTy,
charDataCon, charTy, stringTy,
smallIntegerDataCon, isIntegerTy
)
-import BasicTypes ( RecFlag(..) )
+import BasicTypes ( RecFlag(..), Boxity(..) )
import Maybes ( maybeToBool )
-import Unique ( Uniquable(..), ratioTyConKey )
+import Unique ( Uniquable(..), hasKey, ratioTyConKey, addr2IntegerIdKey )
import Util ( zipEqual, zipWithEqual )
import Outputable
-- "_" => build (\ c n -> c 'c' n) -- LATER
dsExpr (HsLitOut (HsString str) _)
- = returnDs (mkStringLitFS str)
+ = mkStringLitFS str
dsExpr (HsLitOut (HsLitLit str) ty)
- | isUnLiftedType ty
- = returnDs (mkLit (MachLitLit str ty))
- | otherwise
- = 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 (mkIntegerLit i)
+ = mkIntegerLit i
dsExpr (HsLitOut (HsFrac r) ty)
- = returnDs (mkConApp ratio_data_con [Type integer_ty,
- mkIntegerLit (numerator r),
- mkIntegerLit (denominator r)])
+ = mkIntegerLit (numerator r) `thenDs` \ num ->
+ mkIntegerLit (denominator r) `thenDs` \ denom ->
+ returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom])
where
(ratio_data_con, integer_ty)
= case (splitAlgTyConApp_maybe ty) of
Just (tycon, [i_ty], [con])
- -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
+ -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
(con, i_ty)
_ -> (panic "ratio_data_con", panic "integer_ty")
-
-- others where we know what to do:
dsExpr (HsLitOut (HsIntPrim i) _)
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 (Match _ [TuplePat ps Unboxed] _ _) = True
ubx_tuple_match _ = False
dsExpr (HsCase discrim matches src_loc)
dsExpr (ExplicitListOut ty xs)
= go xs
where
- list_ty = mkListTy ty
-
go [] = returnDs (mkNilExpr ty)
go (x:xs) = dsExpr x `thenDs` \ core_x ->
go xs `thenDs` \ core_xs ->
ASSERT( isNotUsgTy ty )
returnDs (mkConsExpr ty core_x core_xs)
-dsExpr (ExplicitTuple expr_list boxed)
+dsExpr (ExplicitTuple expr_list boxity)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
- returnDs (mkConApp ((if boxed
- then tupleCon
- else unboxedTupleCon) (length expr_list))
- (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs))
+ returnDs (mkConApp (tupleCon boxity (length expr_list))
+ (map (Type . unUsgTy . exprType) core_exprs ++ core_exprs))
-- the above unUsgTy is *required* -- KSW 1999-04-07
dsExpr (ArithSeqOut expr (From from))
-- necessary so that we don't lose sharing
let
- 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
+ record_in_ty = exprType record_expr'
+ (_, in_inst_tys, cons) = splitAlgTyConApp record_in_ty
+ (_, out_inst_tys, _) = splitAlgTyConApp record_out_ty
+ cons_to_upd = filter has_all_fields cons
mk_val_arg field old_arg_id
= case [rhs | (sel_id, rhs, _) <- rbinds,
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
- rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConId con))
+ rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConWrapId con))
out_inst_tys)
dicts)
val_args
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
let msg = ASSERT( isNotUsgTy b_ty )
- "Pattern match failure in do expression, " ++ showSDoc (ppr locn) in
+ "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
+ in
+ mkStringLit msg `thenDs` \ core_msg ->
returnDs (mkIfThenElse expr2
rest
(App (App (Var fail_id)
(Type b_ty))
- (mkStringLit msg)))
+ core_msg))
go (ExprStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
\end{code}
\begin{code}
-mkIntegerLit :: Integer -> CoreExpr
+mkIntegerLit :: Integer -> DsM CoreExpr
mkIntegerLit i
| inIntRange i -- Small enough, so start from an Int
- = mkConApp smallIntegerDataCon [mkIntLit i]
+ = returnDs (mkConApp smallIntegerDataCon [mkIntLit i])
| otherwise -- Big, so start from a string
- = App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i))))
+ = dsLookupGlobalValue addr2IntegerIdKey `thenDs` \ addr2IntegerId ->
+ returnDs (App (Var addr2IntegerId) (Lit (MachStr (_PK_ (show i)))))
\end{code}
projects / ghc-hetmet.git / blobdiff