Skip to content
This repository has been archived by the owner on Feb 10, 2020. It is now read-only.

Commit

Permalink
Use fn/arity references, and mod:fn
Browse files Browse the repository at this point in the history 
- fn/N in place of fn() where fn both has an overload of arity N and actually returns something of that arity,
  i.e. for regular curried fns this means N=1, for FnN and EffectFnN this applies more generally
- Switch function calls (and references) to the same module to use module: prefixed version if the identifier is
  exported, to better support code upgrade
- Fix run(Effect)FnN inlining which was not firing
  • Loading branch information
@nwolverson
nwolverson committed Sep 18, 2018
1 parent eb0e3f1 commit 40bb8e7
Show file tree
Hide file tree
Showing 3 changed files with 62 additions and 29 deletions.
66 changes: 44 additions & 22 deletions src/Language/PureScript/CodeGen/Erl.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -74,6 +74,12 @@ uncurriedFnArity moduleName fnName = go (-1)
go n (ForAll _ ty _) = go n ty
go _ _ = Nothing

effectUncurried :: ModuleName
effectUncurried = ModuleName [ ProperName "Effect", ProperName "Uncurried" ]

dataFunctionUncurried :: ModuleName
dataFunctionUncurried = ModuleName [ ProperName "Data", ProperName "Function", ProperName "Uncurried" ]

-- |
-- Generate code in the simplified Erlang intermediate representation for all declarations in a
-- module.
Expand Down Expand Up @@ -169,33 +175,42 @@ moduleToErl env (Module _ _ mn _ _ declaredExports foreigns decls) foreignExport
Just t -> uncurriedFnArity fnMod fn t
_ -> Nothing

effFnArity = uncurriedFnArity' effectUncurried "EffectFn"
fnArity = uncurriedFnArity' dataFunctionUncurried "Fn"

topNonRecToErl :: Ann -> Ident -> Expr Ann -> m ([(Atom,Int)], [ Erl ])
topNonRecToErl (ss, _, _, _) ident val = do
erl <- valueToErl val
let (_, _, _, meta') = extractAnn val
let eann@(_, _, _, meta') = extractAnn val
ident' = case meta' of
Just IsTypeClassConstructor -> identToTypeclassCtor ident
_ -> Atom Nothing $ runIdent ident
qident = Qualified (Just mn) ident

vars arity = replicateM arity freshNameErl

curried = ( [ (ident', 0) ], [ EFunctionDef (Just ss) ident' [] erl ] )
effFnArity = uncurriedFnArity' (ModuleName [ ProperName "Effect", ProperName "Uncurried" ]) "EffectFn" qident
fnArity = uncurriedFnArity' (ModuleName [ ProperName "Data", ProperName "Function", ProperName "Uncurried" ]) "Fn" qident
uncurried <- case fromMaybe 0 (M.lookup qident arities) of
_ | Just arity <- effFnArity <|> fnArity -> do
avars <- vars arity
pure ( [ (ident', arity) ], [ EFunctionDef (Just ss) ident' avars $ EApp erl (map EVar avars) ] )
0 -> pure ( [], [] )
arity -> do
avars <- vars arity
pure ( [ (ident', arity) ], [ EFunctionDef (Just ss) ident' avars $ curriedApp (map EVar avars) erl ] )
-- Always generate the plain curried form, f x y = ... -~~> f() -> fun (X) -> fun (Y) -> ... end end.
erl <- valueToErl val
let curried = ( [ (ident', 0) ], [ EFunctionDef (Just ss) ident' [] erl ] )

-- For effective > 0 (either plain curried funs, FnX or EffectFnX) generate an uncurried overload
-- f x y = ... -~~> f(X,Y) -> ((...)(X))(Y).
-- Relying on inlining to clean up some junk here
let mkRunApp modName prefix n = App eann (Var eann (Qualified (Just modName) (Ident $ prefix <> T.pack (show n))))
(wrap, unwrap) = case effFnArity qident of
Just n -> (mkRunApp effectUncurried C.runEffectFn n, \e -> EApp e [])
_ | Just n <- fnArity qident -> (mkRunApp dataFunctionUncurried C.runFn n, id)
_ -> (id, id)

uncurried <- case effFnArity qident <|> fnArity qident <|> M.lookup qident arities of
Just arity | arity > 0 -> do
vars <- replicateM arity freshNameErl
-- Apply in CoreFn then translate to take advantage of translation of full/partial application
erl' <- valueToErl $ foldl (\fn a -> App eann fn (Var eann (Qualified Nothing (Ident a)))) (wrap val) vars
pure ( [ (ident', arity) ], [ EFunctionDef (Just ss) ident' vars (unwrap erl') ] )
_ -> pure ([], [])

let res = curried <> uncurried
pure $ case ident `Set.member` declaredExportsSet of
True -> res
False -> ([], snd res)

pure $ if ident `Set.member` declaredExportsSet
then res
else ([], snd res)

bindToErl :: Bind Ann -> m [Erl]
bindToErl (NonRec _ ident val) =
Expand Down Expand Up @@ -226,8 +241,9 @@ moduleToErl env (Module _ _ mn _ _ declaredExports foreigns decls) foreignExport
qualifiedToErl' mn' moduleType ident = Atom (Just $ atomModuleName mn' moduleType) (runIdent ident)

-- Top level definitions are everywhere fully qualified, variables are not.
qualifiedToErl (Qualified (Just mn') ident) | mn == mn' = Atom Nothing (runIdent ident)
qualifiedToErl (Qualified (Just mn') ident) = qualifiedToErl' mn' PureScriptModule ident
qualifiedToErl (Qualified (Just mn') ident) | mn == mn' && ident `Set.notMember` declaredExportsSet =
Atom Nothing (runIdent ident) -- Local reference to local non-exported function
qualifiedToErl (Qualified (Just mn') ident) = qualifiedToErl' mn' PureScriptModule ident -- Reference other modules or exported things via module name
qualifiedToErl _ = error "Invalid qualified identifier"

qualifiedToVar (Qualified _ ident) = identToVar ident
Expand All @@ -240,7 +256,13 @@ moduleToErl env (Module _ _ mn _ _ declaredExports foreigns decls) foreignExport
rethrowWithPosition pos $ literalToValueErl l
valueToErl' _ (Var _ (Qualified (Just (ModuleName [ProperName prim])) (Ident undef))) | prim == C.prim, undef == C.undefined =
return $ EAtomLiteral $ Atom Nothing C.undefined
valueToErl' _ (Var _ ident) | isTopLevelBinding ident = return $ EApp (EAtomLiteral $ qualifiedToErl ident) []
valueToErl' _ (Var _ ident) | isTopLevelBinding ident = pure $
case M.lookup ident arities of
Just 1 -> EFunRef (qualifiedToErl ident) 1
_ | Just arity <- effFnArity ident <|> fnArity ident
, arity > 0 -> EFunRef (qualifiedToErl ident) arity
_ -> EApp (EAtomLiteral $ qualifiedToErl ident) []

valueToErl' _ (Var _ ident) = return $ EVar $ qualifiedToVar ident

valueToErl' ident (Abs _ arg val) = do
Expand Down
3 changes: 3 additions & 0 deletions src/Language/PureScript/CodeGen/Erl/Optimizer/Common.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,9 @@ isUncurriedFn :: (Text, PSString) -> Erl -> Bool
isUncurriedFn (moduleName, dictName) (EAtomLiteral (Atom (Just x) y)) = x == moduleName && y == atomPS dictName
isUncurriedFn _ _ = False

isCurriedFn :: (Text, PSString) -> Erl -> Bool
isCurriedFn = isDict

applyAll :: [a -> a] -> a -> a
applyAll = foldl1 (.)

Expand Down
22 changes: 15 additions & 7 deletions src/Language/PureScript/CodeGen/Erl/Optimizer/Inliner.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -190,17 +190,25 @@ inlineCommonOperators = everywhereOnErlTopDown $ applyAll $
runFn' :: Text -> Text -> (Erl -> [Erl] -> Erl) -> Int -> Erl -> Erl
runFn' modName runFnName res n = convert where
convert :: Erl -> Erl
convert e = fromMaybe e $ go n [] e
convert e = fromMaybe e $ go e

go :: Int -> [Erl] -> Erl -> Maybe Erl
go 0 acc (EApp runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
Just $ res fn acc
go m acc (EApp lhs [arg]) = go (m - 1) (arg : acc) lhs
go _ _ _ = Nothing
go :: Erl -> Maybe Erl
go (EApp runFnN (fn : args))
| isNFn modName runFnName n runFnN
, length args == n
= Just $ res (normaliseRef fn) args
go _ = Nothing

normaliseRef (EFunRef _ arity) | arity /= n = error "Should never see wrong arity here"
normaliseRef (EFunRef fn _) = EAtomLiteral fn
normaliseRef other = other

isNFn :: Text -> Text -> Int -> Erl -> Bool
isNFn expectMod prefix n fn | isUncurriedFn (expectMod, (mkString $ prefix <> T.pack (show n))) fn = True
isNFn expectMod prefix n fn
| isUncurriedFn (expectMod, name) fn = True
where name = mkString $ prefix <> T.pack (show n)
isNFn _ _ _ _ = False


semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
semiringNumber = (EC.dataSemiring, C.semiringNumber)
Expand Down

0 comments on commit 40bb8e7

Please sign in to comment.