From 97a8fe8780307e95829034117efa98d2e27109cd Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 27 May 2009 18:08:40 +0000 Subject: [PATCH] Template Haskell: improve lifting for strings When you have a (\s::String -> ....[| s |]....), the string 's' is lifted. We used to get a chain of single-character Cons nodes, correct but lots and lots of code. This patch arranges to optimise that to a string literal. It does so in two places: a) In TcExpr, if we know that s::String, we generate liftString directly b) In DsMeta, if we find a list of character literals, we convert to a string. This catches a few cases that (a) does not There an accompanying patch in the template-haskell package, adding Language.Haskell.TH.Syntax.liftString --- compiler/deSugar/DsMeta.hs | 17 +++++++++++------ compiler/hsSyn/Convert.lhs | 20 +++++++++++++++++++- compiler/typecheck/TcExpr.lhs | 23 +++++++++++++++++++---- 3 files changed, 49 insertions(+), 11 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 5303f9d..9aac831 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -23,7 +23,7 @@ module DsMeta( dsBracket, templateHaskellNames, qTyConName, nameTyConName, - liftName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, + liftName, liftStringName, expQTyConName, patQTyConName, decQTyConName, typeQTyConName, decTyConName, typeTyConName, mkNameG_dName, mkNameG_vName, mkNameG_tcName, quoteExpName, quotePatName ) where @@ -1757,12 +1757,13 @@ predTyConName = thTc (fsLit "Pred") predTyConKey returnQName, bindQName, sequenceQName, newNameName, liftName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, - mkNameLName :: Name -returnQName = thFun (fsLit "returnQ") returnQIdKey -bindQName = thFun (fsLit "bindQ") bindQIdKey -sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey + mkNameLName, liftStringName :: Name +returnQName = thFun (fsLit "returnQ") returnQIdKey +bindQName = thFun (fsLit "bindQ") bindQIdKey +sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey newNameName = thFun (fsLit "newName") newNameIdKey -liftName = thFun (fsLit "lift") liftIdKey +liftName = thFun (fsLit "lift") liftIdKey +liftStringName = thFun (fsLit "liftString") liftStringIdKey mkNameName = thFun (fsLit "mkName") mkNameIdKey mkNameG_vName = thFun (fsLit "mkNameG_v") mkNameG_vIdKey mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey @@ -2053,6 +2054,9 @@ floatPrimLIdKey = mkPreludeMiscIdUnique 215 doublePrimLIdKey = mkPreludeMiscIdUnique 216 rationalLIdKey = mkPreludeMiscIdUnique 217 +liftStringIdKey :: Unique +liftStringIdKey = mkPreludeMiscIdUnique 218 + -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey :: Unique @@ -2081,6 +2085,7 @@ matchIdKey = mkPreludeMiscIdUnique 231 clauseIdKey :: Unique clauseIdKey = mkPreludeMiscIdUnique 232 + -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey, diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index fc915db..b4d897d 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -508,7 +508,10 @@ cvtl e = wrapL (cvt e) cvt (DoE ss) = cvtHsDo DoExpr ss cvt (CompE ss) = cvtHsDo ListComp ss cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' } - cvt (ListE xs) = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } + cvt (ListE xs) + | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') } + -- Note [Converting strings] + | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y ; e' <- returnL $ OpApp x' s' undefined y' ; return $ HsPar e' } @@ -597,6 +600,21 @@ cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal" -- An Integer is like an (overloaded) '3' in a Haskell source program -- Similarly 3.5 for fractionals +{- Note [Converting strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to +a string literal for "xy". Of course, we might hope to get +(LitE (StringL "xy")), but not always, and allCharLs fails quickly +if it isn't a literal string +-} + +allCharLs :: [TH.Exp] -> Maybe String +-- Note [Converting strings] +allCharLs (LitE (CharL c) : xs) + | Just cs <- allCharLs xs = Just (c:cs) +allCharLs [] = Just [] +allCharLs _ = Nothing + cvtLit :: Lit -> CvtM HsLit cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w } diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 1508995..784d466 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1152,18 +1152,33 @@ thBrackId orig id ps_var lie_var -- so we zap it to a LiftedTypeKind monotype -- C.f. the call in TcPat.newLitInst - ; setLIEVar lie_var $ do - { lift <- newMethodFromName orig id_ty' DsMeta.liftName - -- Put the 'lift' constraint into the right LIE + ; lift <- if isStringTy id_ty' then + tcLookupId DsMeta.liftStringName + -- See Note [Lifting strings] + else + setLIEVar lie_var $ do -- Put the 'lift' constraint into the right LIE + newMethodFromName orig id_ty' DsMeta.liftName -- Update the pending splices ; ps <- readMutVar ps_var ; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) - ; return id } } + ; return id } #endif /* GHCI */ \end{code} +Note [Lifting strings] +~~~~~~~~~~~~~~~~~~~~~~ +If we see $(... [| s |] ...) where s::String, we don't want to +generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc. +So this conditional short-circuits the lifting mechanism to generate +(liftString "xy") in that case. I didn't want to use overlapping instances +for the Lift class in TH.Syntax, because that can lead to overlapping-instance +errors in a polymorphic situation. + +If this check fails (which isn't impossible) we get another chance; see +Note [Converting strings] in Convert.lhs + Local record selectors ~~~~~~~~~~~~~~~~~~~~~~ Record selectors for TyCons in this module are ordinary local bindings, -- 1.7.10.4