moduleLanguage.HERMIT.Primitive.GHC(-- * GHC-based Transformations-- | This module contains transformations that are reflections of GHC functions, or derived from GHC functions.externals-- ** Free Variables,coreExprFreeIds,coreExprFreeVars,freeIdsT,freeVarsT,altFreeVarsT,altFreeVarsExclWildT-- ** Substitution,substR,letSubstR,safeLetSubstR,safeLetSubstPlusR-- ** Utilities,inScope,exprEqual,showVars,rules)whereimportGhcPluginsimportqualifiedOccurAnalimportControl.ArrowimportControl.MonadimportData.List(intercalate,mapAccumL,(\\))importLanguage.HERMIT.CoreimportLanguage.HERMIT.ContextimportLanguage.HERMIT.MonadimportLanguage.HERMIT.KureimportLanguage.HERMIT.ExternalimportLanguage.HERMIT.GHCimportLanguage.HERMIT.Primitive.Navigationhiding(externals)importqualifiedLanguage.Haskell.THasTH-------------------------------------------------------------------------- | Externals that reflect GHC functions, or are derived from GHC functions.externals::[External]externals=[external"info"(info::TranslateHCoreString)["display information about the current node."],external"let-subst"(promoteExprRletSubstR::RewriteHCore)["Let substitution","(let x = e1 in e2) ==> (e2[e1/x])","x must not be free in e1."].+Deep,external"safe-let-subst"(promoteExprRsafeLetSubstR::RewriteHCore)["Safe let substitution","let x = e1 in e2, safe to inline without duplicating work ==> e2[e1/x],","x must not be free in e1."].+Deep.+Eval.+Bash,external"safe-let-subst-plus"(promoteExprRsafeLetSubstPlusR::RewriteHCore)["Safe let substitution","let { x = e1, ... } in e2, "," where safe to inline without duplicating work ==> e2[e1/x,...],","only matches non-recursive lets"].+Deep.+Eval,external"free-ids"(promoteExprTfreeIdsQuery::TranslateHCoreString)["List the free identifiers in this expression."].+Query.+Deep,external"deshadow-prog"(promoteProgRdeShadowProgR::RewriteHCore)["Deshadow a program."].+Deep,external"apply-rule"(promoteExprR.rules::String->RewriteHCore)["apply a named GHC rule"].+Shallow,external"apply-rule"(rules_help::TranslateHCoreString)["list rules that can be used"].+Query,external"compare-values"compareValues["compare the rhs of two values."].+Query.+Predicate,external"add-rule"(\rule_nameid_name->promoteModGutsR(addCoreBindAsRulerule_nameid_name))["add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"].+Introduce,external"cast-elim"(promoteExprRcastElimination)["cast-elim removes casts"].+Shallow.+Experiment.+TODO,external"add-rule"(\rule_nameid_name->promoteModGutsR(addCoreBindAsRulerule_nameid_name))["add-rule \"rule-name\" <id> -- adds a new rule that freezes the right hand side of the <id>"],external"occur-analysis"(promoteExprRoccurAnalyseExprR::RewriteHCore)["Performs dependency anlaysis on a CoreExpr.","This can be useful to simplify a recursive let to a non-recursive let."].+Deep]-------------------------------------------------------------------------- | Substitute all occurrences of a variable with an expression, in either a program or an expression.substR::Var->CoreExpr->RewriteHCoresubstRve=setFailMsg"Can only perform substitution on expressions or programs."$promoteExprR(substExprRve)<+promoteProgR(substTopBindRve)-- | Substitute all occurrences of a variable with an expression, in an expression.substExprR::Var->CoreExpr->RewriteHCoreExprsubstExprRve=contextfreeT$\expr->-- The InScopeSet needs to include any free variables appearing in the-- expression to be substituted. Constructing a NonRec Let expression-- to pass on to exprFeeVars takes care of this, but ...-- TODO Is there a better way to do this ???letemptySub=mkEmptySubst(mkInScopeSet(exprFreeVars(Let(NonRecve)expr)))indosub<-ifisTyVarvthencaseeofTypevty->return$extendTvSubstemptySubvvtyVarx->return$extendTvSubstemptySubv(mkTyVarTyx)_->fail"substExprR: Var argument is a TyVar, but the expression is not a Type."elsereturn$extendSubstemptySubvereturn$substExpr(text"substR")subexpr-- | Substitute all occurrences of a variable with an expression, in a program.substTopBindR::Var->CoreExpr->RewriteHCoreProgsubstTopBindRve=contextfreeT$\p->-- TODO. Do we need to initialize the emptySubst with bindFreeVars?letemptySub=emptySubst-- mkEmptySubst (mkInScopeSet (exprFreeVars exp))indosub<-ifisTyVarvthencaseeofTypevty->return$extendTvSubstemptySubvvtyVarx->return$extendTvSubstemptySubv(mkTyVarTyx)_->fail"substTopBindR: Var argument is a TyVar, but the expression is not a Type."elsereturn$extendSubstemptySubvereturn$bindsToProg$snd(mapAccumLsubstBindsub(progToBindsp))-- | (let x = e1 in e2) ==> (e2[e1/x]),-- x must not be free in e1.letSubstR::RewriteHCoreExprletSubstR=prefixFailMsg"Let substition failed: "$rewrite$\cexpr->caseoccurAnalyseExprexprofLet(NonRecbbe)e->apply(substExprRbbe)ce_->fail"expression is not a non-recursive Let."-- Neil: Commented this out as it's not (currently) used.-- Perform let-substitution the specified number of times.-- letSubstNR :: Int -> RewriteH Core-- letSubstNR 0 = idR-- letSubstNR n = childR 1 (letSubstNR (n - 1)) >>> promoteExprR letSubstR-- | This is quite expensive (O(n) for the size of the sub-tree).safeLetSubstR::RewriteHCoreExprsafeLetSubstR=prefixFailMsg"Safe let-substition failed: "$translate$\envexpr->let-- Lit?safeBind(Var{})=TruesafeBind(Lam{})=TruesafeBinde@(App{})=casecollectArgseof(Varf,args)->arityOfenvf>length(filter(not.isTypeArg)args)(other,args)->casecollectBindersotherof(bds,_)->lengthbds>lengthargssafeBind_=FalsesafeSubstNoOccInfo=False-- unknown!safeSubstIAmDead=True-- DCEsafeSubst(OneOccinLamoneBr_)=notinLam&&oneBr-- do not inline inside a lambda or if in multiple case branchessafeSubst_=False-- strange case, like a loop breakerincaseoccurAnalyseExprexprof-- By (our) definition, types are a trivial bindLet(NonRecb_)_|isTyVarb->applyletSubstRenvexprLet(NonRecbbe)_|isIdb&&(safeBindbe||safeSubst(occInfo(idInfob)))->applyletSubstRenvexpr|otherwise->fail"safety critera not met."_->fail"expression is not a non-recursive Let."-- | 'safeLetSubstPlusR' tries to inline a stack of bindings, stopping when reaches-- the end of the stack of lets.safeLetSubstPlusR::RewriteHCoreExprsafeLetSubstPlusR=tryR(letTidRsafeLetSubstPlusRLet)>>>safeLetSubstR------------------------------------------------------------------------info::TranslateHCoreStringinfo=translate$\ccore->dodynFlags<-getDynFlagsletpa="Path: "++show(contextPathc)node="Node: "++coreNodecorecon="Constructor: "++coreConstructorcorebds="Bindings in Scope: "++show(mapunqualifiedVarName$boundVarsc)expExtra=casecoreofExprCoree->["Type or Kind: "++showExprTypeOrKinddynFlagse]++["Free Variables: "++showVars(coreExprFreeVarse)]-- ++-- case e of-- Var v -> ["Identifier Info: " ++ showIdInfo dynFlags v] -- TODO: what if this is a TyVar?-- _ -> []_->[]return(intercalate"\n"$[pa,node,con,bds]++expExtra)showExprTypeOrKind::DynFlags->CoreExpr->StringshowExprTypeOrKinddynFlags=showPprdynFlags.exprTypeOrKind-- showIdInfo :: DynFlags -> Id -> String-- showIdInfo dynFlags v = showSDoc dynFlags $ ppIdInfo v $ idInfo vcoreNode::Core->StringcoreNode(ModGutsCore_)="Module"coreNode(ProgCore_)="Program"coreNode(BindCore_)="Binding Group"coreNode(DefCore_)="Recursive Definition"coreNode(ExprCore_)="Expression"coreNode(AltCore_)="Case Alternative"coreConstructor::Core->StringcoreConstructor(ModGutsCore_)="ModGuts"coreConstructor(ProgCoreprog)=caseprogofProgNil->"ProgNil"ProgCons__->"ProgCons"coreConstructor(BindCorebnd)=casebndofRec_->"Rec"NonRec__->"NonRec"coreConstructor(DefCore_)="Def"coreConstructor(AltCore_)="(,,)"coreConstructor(ExprCoreexpr)=caseexprofVar_->"Var"Type_->"Type"Lit_->"Lit"App__->"App"Lam__->"Lam"Let__->"Let"Case____->"Case"Cast__->"Cast"Tick__->"Tick"Coercion_->"Coercion"-------------------------------------------------------------------------- | Output a list of all free variables in an expression.freeIdsQuery::TranslateHCoreExprStringfreeIdsQuery=dofrees<-freeIdsTreturn$"Free identifiers are: "++showVarsfrees-- | Show a human-readable version of a list of 'Var's.showVars::[Var]->StringshowVars=show.mapvar2String-- | Lifted version of 'coreExprFreeIds'.freeIdsT::TranslateHCoreExpr[Id]freeIdsT=arrcoreExprFreeIds-- | Lifted version of 'coreExprFreeVars'.freeVarsT::TranslateHCoreExpr[Var]freeVarsT=arrcoreExprFreeVars-- | List all free variables (including types) in the expression.coreExprFreeVars::CoreExpr->[Var]coreExprFreeVars=uniqSetToList.exprFreeVars-- | List all free identifiers (value-level free variables) in the expression.coreExprFreeIds::CoreExpr->[Id]coreExprFreeIds=uniqSetToList.exprFreeIds-- | The free variables in a case alternative, which excludes any identifiers bound in the alternative.altFreeVarsT::TranslateHCoreAlt[Var]altFreeVarsT=altTfreeVarsT(\_vsfvs->fvs\\vs)-- | A variant of 'altFreeVarsT' that returns a function that accepts the case wild-card binder before giving a result.-- This is so we can use this with congruence combinators, for example:---- caseT id (const altFreeVarsT) $ \ _ wild _ fvs -> [ f wild | f <- fvs ]altFreeVarsExclWildT::TranslateHCoreAlt(Id->[Var])altFreeVarsExclWildT=altTfreeVarsT(\_vsfvswild->fvs\\(wild:vs))-------------------------------------------------------------------------- | [from GHC documentation] De-shadowing the program is sometimes a useful pre-pass.-- It can be done simply by running over the bindings with an empty substitution,-- becuase substitution returns a result that has no-shadowing guaranteed.---- (Actually, within a single /type/ there might still be shadowing, because-- 'substTy' is a no-op for the empty substitution, but that's probably OK.)deShadowProgR::RewriteHCoreProgdeShadowProgR=arr(bindsToProg.deShadowBinds.progToBinds)------------------------------------------------------------------------{-
lookupRule :: (Activation -> Bool) -- When rule is active
-> IdUnfoldingFun -- When Id can be unfolded
-> InScopeSet
-> Id -> [CoreExpr]
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-}-- Neil: Commented this out as its not (currently) used.-- rulesToEnv :: [CoreRule] -> Map.Map String (RewriteH CoreExpr)-- rulesToEnv rs = Map.fromList-- [ ( unpackFS (ruleName r), rulesToRewriteH [r] )-- | r <- rs-- ]rulesToRewriteH::[CoreRule]->RewriteHCoreExprrulesToRewriteHrs=translate$\ce->do-- First, we normalize the lhs, so we can match it(Varfn,args)<-return$collectArgse-- Question: does this include Id's, or Var's (which include type names)-- Assumption: Var's.letin_scope=mkInScopeSet(mkVarEnv[(v,v)|v<-coreExprFreeVarse])-- The rough_args are just an attempt to try eliminate silly things-- that will never match_rough_args=map(constNothing)args-- rough_args are never used!!! FIX ME!-- Finally, we try match the rules-- trace (showSDoc (ppr fn GhcPlugins.<+> ppr args $$ ppr rs)) $caselookupRule(constTrue)(constNoUnfolding)in_scopefnargsrsofNothing->fail"rule not matched"Just(rule,expr)->dolete'=mkAppsexpr(drop(ruleArityrule)args)ifM(liftM(and.map(inScopec))$applyfreeVarsTce')(returne')(fail$unlines["Resulting expression after rule application contains variables that are not in scope.","This can probably be solved by running the flatten-module command at the top level."])-- | Determine whether an identifier is in scope.inScope::HermitC->Id->BoolinScopecv=(v`boundIn`c)||-- defined in this modulecaseunfoldingInfo(idInfov)ofCoreUnfolding{}->True-- defined elsewhere_->False-- | Lookup a rule and attempt to construct a corresponding rewrite.rules::String->RewriteHCoreExprrulesr=dotheRules<-getHermitRulescaselookuprtheRulesofNothing->fail$"failed to find rule: "++showrJustrr->rulesToRewriteHrrgetHermitRules::TranslateHa[(String,[CoreRule])]getHermitRules=translate$\env_->dorb<-liftCoreMgetRuleBaseletother_rules=[rule|top_bnds<-mg_binds(hermitModGutsenv),bnd<-casetop_bndsofRecbnds->mapfstbndsNonRecb_->[b],rule<-idCoreRulesbnd]return[(unpackFS(ruleNamer),[r])|r<-mg_rules(hermitModGutsenv)++other_rules++concat(nameEnvEltsrb)]rules_help::TranslateHCoreStringrules_help=dorulesEnv<-getHermitRulesdynFlags<-constTgetDynFlagsreturn$(show(mapfstrulesEnv)++"\n")++showSDocdynFlags(pprRulesForUser$concatMapsndrulesEnv)makeRule::String->Id->CoreExpr->CoreRulemakeRulerule_namenm=mkRuleTrue-- auto-generatedFalse-- local(mkFastStringrule_name)NeverActive-- because we need to call for these(varNamenm)[][]-- TODO: check if a top-level bindingaddCoreBindAsRule::String->TH.Name->RewriteHModGutsaddCoreBindAsRulerule_namenm=contextfreeT$\modGuts->case[(v,e)|top_bnds<-mg_bindsmodGuts,(v,e)<-casetop_bndsofRecbnds->bndsNonRecbe->[(b,e)],nm`cmpTHName2Var`v]of[]->fail$"cannot find binding "++shownm[(v,e)]->return$modGuts{mg_rules=mg_rulesmodGuts++[makeRulerule_nameve]}_->fail$"found multiple bindings for "++shownm------------------------------------------------------------------------ | Performs dependency anlaysis on an expression.-- This can be useful to simplify a non-recursive recursive binding group to a non-recursive binding group.occurAnalyseExpr::CoreExpr->CoreExproccurAnalyseExpr=OccurAnal.occurAnalyseExpr-- | Lifted version of 'occurAnalyseExpr'occurAnalyseExprR::RewriteHCoreExproccurAnalyseExprR=arroccurAnalyseExpr{- Does not work (no export)
-- Here is a hook into the occur analysis, and a way of looking at the result
occAnalysis :: CoreExpr -> UsageDetails
occAnalysis = fst . occAnal (initOccEnv all_active_rules)
lookupUsageDetails :: UsageDetails -> Var -> Maybe OccInfo
lookupUsageDetails = lookupVarEnv
-}exprEqual::CoreExpr->CoreExpr->BoolexprEquale1e2=eqExpr(mkInScopeSet$exprsFreeVars[e1,e2])e1e2-- The ideas for this function are directly extracted from-- the GHC function, CoreUtils.eqExprXbindEqual::CoreBind->CoreBind->MaybeBoolbindEqual(Recps1)(Recps2)=Just$all2(eqExprXid_unfenv')rs1rs2whereid_unf_=noUnfolding-- Don't expand(bs1,rs1)=unzipps1(bs2,rs2)=unzipps2env=mkInScopeSet$exprsFreeVars(rs1++rs2)-- emptyInScopeSetenv'=rnBndrs2(mkRnEnv2env)bs1bs2bindEqual(NonRec_e1)(NonRec_e2)=Just$exprEquale1e2bindEqual__=Nothing--------------------------------------------------------coreEqual::Core->Core->MaybeBoolcoreEqual(ExprCoree1)(ExprCoree2)=Just$e1`exprEqual`e2coreEqual(BindCoreb1)(BindCoreb2)=b1`bindEqual`b2coreEqual(DefCoredc1)(DefCoredc2)=defsToRecBind[dc1]`bindEqual`defsToRecBind[dc2]coreEqual__=NothingcompareValues::TH.Name->TH.Name->TranslateHCore()compareValuesn1n2=dop1<-onePathToT(namedBindingn1)p2<-onePathToT(namedBindingn2)e1<-pathTp1idRe2<-pathTp2idRcasee1`coreEqual`e2ofNothing->fail$shown1++" and "++shown2++" are incomparable."JustFalse->fail$shown1++" and "++shown2++" are not equal."JustTrue->return()---------------------------------------------------------- | Try to figure out the arity of an identifier.arityOf::HermitC->Id->IntarityOfenvnm=caselookupHermitBindingnmenvofNothing->idAritynmJust(LAM{})->0-- Note: the exprArity will call idArity if-- it hits an id; perhaps we should do the counting-- The advantage of idArity is it will terminate, though.Just(BIND__e)->exprArityeJust(CASE_e_)->exprAritye--------------------------------------------- remove a cast;-- TODO: check for validity of removing this castcastElimination::RewriteHCoreExprcastElimination=doCaste_<-idRreturne{-
go (Cast e co) | isReflCo co' = go e
| otherwise = Cast (go e) co'
where
co' = optCoercion (getCvSubst subst) co
-}