Cleanup in Compile.newt, don't emit vestigial letrec
This commit is contained in:
@@ -145,7 +145,9 @@ termToJS env (CLet nm t u) f =
|
|||||||
in case termToJS env t (JAssign nm') of
|
in case termToJS env t (JAssign nm') of
|
||||||
(JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
|
(JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
|
||||||
t' => JSnoc (JLet nm' t') (termToJS env' u f)
|
t' => JSnoc (JLet nm' t') (termToJS env' u f)
|
||||||
|
termToJS env (CLetRec nm CErased u) f = termToJS (push env JUndefined) u f
|
||||||
termToJS env (CLetRec nm t u) f =
|
termToJS env (CLetRec nm t u) f =
|
||||||
|
-- this shouldn't happen if where is lifted
|
||||||
let nm' = freshName nm env
|
let nm' = freshName nm env
|
||||||
env' = push env (Var nm')
|
env' = push env (Var nm')
|
||||||
-- If it's a simple term, use const
|
-- If it's a simple term, use const
|
||||||
@@ -286,24 +288,11 @@ maybeWrap : JSStmt Return -> JSExp
|
|||||||
maybeWrap (JReturn exp) = exp
|
maybeWrap (JReturn exp) = exp
|
||||||
maybeWrap stmt = Apply (JLam Nil stmt) Nil
|
maybeWrap stmt = Apply (JLam Nil stmt) Nil
|
||||||
|
|
||||||
dcon : QName -> Int -> Doc
|
cexpToDoc : (QName × CExp) -> Doc
|
||||||
dcon qn arity =
|
cexpToDoc (qn, ct) =
|
||||||
let ct = compileDCon qn arity
|
-- If we leak extra statements/assignments, we need an IIFE
|
||||||
exp = maybeWrap $ termToJS emptyJSEnv ct JReturn
|
|
||||||
in stmtToDoc $ JConst (show qn) exp
|
|
||||||
|
|
||||||
-- convert a Def to a Doc (compile to javascript)
|
|
||||||
defToDoc : {{Ref2 Defs St}} → QName → Def → M Doc
|
|
||||||
defToDoc name (Fn tm) = do
|
|
||||||
debug $ \ _ => "compileFun \{render 90 $ pprint Nil tm}"
|
|
||||||
ct <- compileFun tm
|
|
||||||
let exp = maybeWrap $ termToJS emptyJSEnv ct JReturn
|
let exp = maybeWrap $ termToJS emptyJSEnv ct JReturn
|
||||||
pure $ text "const" <+> jsIdent (show name) <+> text "=" <+/> expToDoc exp ++ text ";"
|
in stmtToDoc $ JConst (show qn) exp
|
||||||
defToDoc name Axiom = pure $ text ""
|
|
||||||
defToDoc name (DCon arity _) = pure $ dcon name arity
|
|
||||||
defToDoc name (TCon arity strs) = pure $ dcon name arity
|
|
||||||
defToDoc name (PrimTCon arity) = pure $ dcon name arity
|
|
||||||
defToDoc name (PrimFn src _ _) = pure $ stmtToDoc $ JConst (show name) $ Raw src
|
|
||||||
|
|
||||||
-- Collect the QNames used in a term
|
-- Collect the QNames used in a term
|
||||||
getNames : Tm -> List QName -> List QName
|
getNames : Tm -> List QName -> List QName
|
||||||
@@ -376,15 +365,21 @@ process name = do
|
|||||||
-- Maybe move this dance into liftWhere
|
-- Maybe move this dance into liftWhere
|
||||||
ref <- newIORef entries
|
ref <- newIORef entries
|
||||||
let foo = MkRef ref -- for the autos below
|
let foo = MkRef ref -- for the autos below
|
||||||
|
-- TODO, erasure needs to happen on Tm, but can be part of Tm -> CExp
|
||||||
|
-- if we move the liftWhere down.
|
||||||
eraseEntries
|
eraseEntries
|
||||||
liftWhere
|
liftWhere
|
||||||
tailCallOpt
|
|
||||||
entries <- readIORef ref
|
entries <- readIORef ref
|
||||||
let names = sortedNames entries name
|
let names = sortedNames entries name
|
||||||
|
-- I think this was just debugging
|
||||||
for names $ \ nm => case lookupMap nm entries of
|
for names $ \ nm => case lookupMap nm entries of
|
||||||
Nothing => error emptyFC "MISS \{show nm}"
|
Nothing => error emptyFC "MISS \{show nm}"
|
||||||
Just _ => pure MkUnit
|
Just _ => pure MkUnit
|
||||||
mapM (uncurry defToDoc) $ mapMaybe (\x => lookupMap x entries) names
|
|
||||||
|
exprs <- mapM defToCExp $ toList entries
|
||||||
|
let cexpMap = foldMap const EmptyMap exprs
|
||||||
|
-- TCO here on cexpMap
|
||||||
|
pure $ map cexpToDoc $ mapMaybe (\x => lookupMap x cexpMap) names
|
||||||
|
|
||||||
compile : M (List Doc)
|
compile : M (List Doc)
|
||||||
compile = do
|
compile = do
|
||||||
|
|||||||
@@ -153,3 +153,12 @@ compileDCon (QN _ nm) 0 = CConstr nm Nil
|
|||||||
compileDCon (QN _ nm) arity =
|
compileDCon (QN _ nm) arity =
|
||||||
let args = map (\k => "h\{show k}") (range 0 arity) in
|
let args = map (\k => "h\{show k}") (range 0 arity) in
|
||||||
CFun args $ CConstr nm $ map (\k => CBnd $ arity - k - 1) (range 0 arity)
|
CFun args $ CConstr nm $ map (\k => CBnd $ arity - k - 1) (range 0 arity)
|
||||||
|
|
||||||
|
-- probably want to drop the Ref2 when we can
|
||||||
|
defToCExp : {{Ref2 Defs St}} → (QName × Def) -> M (QName × CExp)
|
||||||
|
defToCExp (qn, Axiom) = pure $ (qn, CErased)
|
||||||
|
defToCExp (qn, DCon arity _) = pure $ (qn, compileDCon qn arity)
|
||||||
|
defToCExp (qn, TCon arity _) = pure $ (qn, compileDCon qn arity)
|
||||||
|
defToCExp (qn, PrimTCon arity) = pure $ (qn, compileDCon qn arity)
|
||||||
|
defToCExp (qn, PrimFn src _ _) = pure $ (qn, CRaw src)
|
||||||
|
defToCExp (qn, Fn tm) = (_,_ qn) <$> compileFun tm
|
||||||
|
|||||||
Reference in New Issue
Block a user