mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult,
mkErrorAppDs, mkNilExpr, mkConsExpr,
+ mkStringLit, mkStringLitFS,
mkSelectorBinds, mkTupleExpr, mkTupleSelector,
import DsMonad
-import CoreUtils ( coreExprType )
+import CoreUtils ( exprType, mkIfThenElse )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
import Id ( idType, Id, mkWildId )
-import Const ( Literal(..), Con(..) )
+import Literal ( Literal(..) )
import TyCon ( isNewTyCon, tyConDataCons )
import DataCon ( DataCon, StrictnessMark, maybeMarkedUnboxed,
dataConStrictMarks, dataConId, splitProductType_maybe
import TysWiredIn ( nilDataCon, consDataCon,
tupleCon,
stringTy,
- unitDataCon, unitTy,
+ unitDataConId, unitTy,
charTy, charDataCon,
intTy, intDataCon,
floatTy, floatDataCon,
addrTy, addrDataCon,
wordTy, wordDataCon
)
+import BasicTypes ( Boxity(..) )
import UniqSet ( mkUniqSet, minusUniqSet, isEmptyUniqSet, UniqSet )
+import Unique ( unpackCStringIdKey, unpackCStringUtf8IdKey )
import Outputable
+import UnicodeUtil ( stringToUtf8 )
\end{code}
| lit_ty == floatTy = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy]
| lit_ty == doubleTy = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy]
- -- Convert the literal pattern "" to the constructor pattern [].
- | null_str_lit lit = ConPat nilDataCon lit_ty [] [] []
- -- Similar special case for "x"
- | one_str_lit lit = ConPat consDataCon lit_ty [] []
- [mk_first_char_lit lit, ConPat nilDataCon lit_ty [] [] []]
+ -- Convert literal patterns like "foo" to 'f':'o':'o':[]
+ | str_lit lit = mk_list lit
| otherwise = default_pat
null_str_lit (HsString s) = _NULL_ s
null_str_lit other_lit = False
- one_str_lit (HsString s) = _LENGTH_ s == (1::Int)
- one_str_lit other_lit = False
- mk_first_char_lit (HsString s) = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim (_HEAD_ s)) charPrimTy]
+ str_lit (HsString s) = True
+ str_lit _ = False
+
+ mk_list (HsString s) = foldr
+ (\c pat -> ConPat consDataCon lit_ty [] [] [mk_char_lit c,pat])
+ (ConPat nilDataCon lit_ty [] [] []) (_UNPK_INT_ s)
+
+ mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy]
\end{code}
returnDs (Case (Var var) var (alts ++ [(DEFAULT, [], fail)]))
mk_alt fail (lit, MatchResult _ body_fn) = body_fn fail `thenDs` \ body ->
- returnDs (Literal lit, [], body)
+ returnDs (LitAlt lit, [], body)
mkCoAlgCaseMatchResult :: Id -- Scrutinee
where
-- Common stuff
scrut_ty = idType var
- (tycon, tycon_arg_tys, _) = splitAlgTyConApp scrut_ty
+ (tycon, _, _) = splitAlgTyConApp scrut_ty
-- Stuff for newtype
- (con_id, arg_ids, match_result) = head match_alts
- arg_id = head arg_ids
- coercion_bind = NonRec arg_id
- (Note (Coerce (unUsgTy (idType arg_id)) (unUsgTy scrut_ty)) (Var var))
- newtype_sanity = null (tail match_alts) && null (tail arg_ids)
+ (_, arg_ids, match_result) = head match_alts
+ arg_id = head arg_ids
+ coercion_bind = NonRec arg_id (Note (Coerce (unUsgTy (idType arg_id))
+ (unUsgTy scrut_ty))
+ (Var var))
+ newtype_sanity = null (tail match_alts) && null (tail arg_ids)
-- Stuff for data types
data_cons = tyConDataCons tycon
= body_fn fail `thenDs` \ body ->
rebuildConArgs con args (dataConStrictMarks con) body
`thenDs` \ (body', real_args) ->
- returnDs (DataCon con, real_args, body')
+ returnDs (DataAlt con, real_args, body')
mk_default fail | exhaustive_case = []
| otherwise = [(DEFAULT, [], fail)]
ASSERT( pack_con == pack_con1 )
newSysLocalsDs con_arg_tys `thenDs` \ unpacked_args ->
returnDs (
- mkDsLet (NonRec arg (Con (DataCon pack_con)
+ mkDsLet (NonRec arg (mkConApp pack_con
(map Type tycon_args ++
map Var unpacked_args))) body',
unpacked_args ++ real_args
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg])
in
- returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, mkStringLit full_msg])
+ mkStringLit full_msg `thenDs` \ core_msg ->
+ returnDs (mkApps (Var err_id) [(Type . unUsgTy) ty, core_msg])
-- unUsgTy *required* -- KSW 1999-04-07
+
+mkStringLit :: String -> DsM CoreExpr
+mkStringLit str = mkStringLitFS (_PK_ str)
+
+mkStringLitFS :: FAST_STRING -> DsM CoreExpr
+mkStringLitFS str
+ | all safeChar chars
+ =
+ dsLookupGlobalValue unpackCStringIdKey `thenDs` \ unpack_id ->
+ returnDs (App (Var unpack_id) (Lit (MachStr str)))
+
+ | otherwise
+ =
+ dsLookupGlobalValue unpackCStringUtf8IdKey `thenDs` \ unpack_id ->
+ returnDs (App (Var unpack_id) (Lit (MachStr (_PK_ (stringToUtf8 chars)))))
+
+ where
+ chars = _UNPK_INT_ str
+ safeChar c = c >= 1 && c <= 0xFF
\end{code}
%************************************************************************
mkSelectorBinds pat val_expr
| length binders == 1 || is_simple_pat pat
- = newSysLocalDs (coreExprType val_expr) `thenDs` \ val_var ->
+ = newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
-- For the error message we don't use mkErrorAppDs to avoid
-- duplicating the string literal each time
let
full_msg = showSDoc (hcat [ppr src_loc, text "|", ppr pat])
in
+ mkStringLit full_msg `thenDs` \ core_msg ->
mapDs (mk_bind val_var msg_var) binders `thenDs` \ binds ->
returnDs ( (val_var, val_expr) :
- (msg_var, mkStringLit full_msg) :
+ (msg_var, core_msg) :
binds )
where
binders = collectTypedPatBinders pat
local_tuple = mkTupleExpr binders
- tuple_ty = coreExprType local_tuple
+ tuple_ty = exprType local_tuple
mk_bind scrut_var msg_var bndr_var
-- (mk_bind sv bv) generates
binder_ty = idType bndr_var
error_expr = mkApps (Var iRREFUT_PAT_ERROR_ID) [Type binder_ty, Var msg_var]
- is_simple_pat (TuplePat ps True{-boxed-}) = all is_triv_pat ps
+ is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps
is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps
is_simple_pat (VarPat _) = True
is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps]
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
-mkTupleExpr [] = mkConApp unitDataCon []
+mkTupleExpr [] = Var unitDataConId
mkTupleExpr [id] = Var id
-mkTupleExpr ids = mkConApp (tupleCon (length ids))
+mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids))
(map (Type . unUsgTy . idType) ids ++ [ Var i | i <- ids ])
\end{code}
mkTupleSelector vars the_var scrut_var scrut
= ASSERT( not (null vars) )
- Case scrut scrut_var [(DataCon (tupleCon (length vars)), vars, Var the_var)]
+ Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
= newFailLocalDs (unitTy `mkFunTy` ty) `thenDs` \ fail_fun_var ->
newSysLocalDs unitTy `thenDs` \ fail_fun_arg ->
returnDs (NonRec fail_fun_var (Lam fail_fun_arg expr),
- App (Var fail_fun_var) (mkConApp unitDataCon []))
+ App (Var fail_fun_var) (Var unitDataConId))
| otherwise
= newFailLocalDs ty `thenDs` \ fail_var ->
returnDs (NonRec fail_var expr, Var fail_var)
where
- ty = coreExprType expr
+ ty = exprType expr
\end{code}
projects / ghc-hetmet.git / blobdiff