418 lines
16 KiB
Agda
418 lines
16 KiB
Agda
-- TODO Audit how much "outside" stuff could pile up in the continuation. (How much might be repeated in case branches.)
|
||
-- TODO consider inlining constructors here (a future inline process might do this anyway).
|
||
-- TODO consider not emitting null in `LitObject` (after inlining constructors)
|
||
module Lib.Compile
|
||
|
||
import Prelude
|
||
import Lib.Common
|
||
import Lib.Types
|
||
import Lib.Prettier
|
||
import Lib.CompileExp
|
||
import Lib.TopContext
|
||
import Lib.LiftWhere
|
||
import Lib.TCO
|
||
import Lib.Ref2
|
||
import Lib.Erasure
|
||
import Data.String
|
||
import Data.Int
|
||
import Data.SortedMap
|
||
import Data.IORef
|
||
|
||
data StKind = Plain | Return | Assign String
|
||
|
||
JSStmt : StKind -> U
|
||
JSExp : U
|
||
|
||
data JAlt : U where
|
||
JConAlt : ∀ e. String -> JSStmt e -> JAlt
|
||
JDefAlt : ∀ e. JSStmt e -> JAlt
|
||
JLitAlt : ∀ e. JSExp -> JSStmt e -> JAlt
|
||
|
||
data JSExp : U where
|
||
LitArray : List JSExp -> JSExp
|
||
LitObject : List (String × JSExp) -> JSExp
|
||
LitString : String -> JSExp
|
||
LitInt : Int -> JSExp
|
||
Apply : JSExp -> List JSExp -> JSExp
|
||
Var : String -> JSExp
|
||
JLam : List String -> JSStmt Return -> JSExp
|
||
JPrimOp : String → JSExp → JSExp → JSExp
|
||
JUndefined : JSExp
|
||
Index : JSExp -> JSExp -> JSExp
|
||
Dot : JSExp -> String -> JSExp
|
||
Raw : String -> JSExp
|
||
|
||
data JSStmt : StKind -> U where
|
||
-- Maybe make this a snoc...
|
||
JSnoc : ∀ a. JSStmt Plain -> JSStmt a -> JSStmt a
|
||
JPlain : JSExp -> JSStmt Plain
|
||
JConst : (nm : String) -> JSExp -> JSStmt Plain
|
||
JReturn : JSExp -> JSStmt Return
|
||
JLet : (nm : String) -> JSStmt (Assign nm) -> JSStmt Plain -- need somebody to assign
|
||
JAssign : (nm : String) -> JSExp -> JSStmt (Assign nm)
|
||
-- TODO - switch to Int tags
|
||
JCase : ∀ a. JSExp -> List JAlt -> JSStmt a
|
||
-- throw can't be used
|
||
JError : ∀ a. String -> JSStmt a
|
||
|
||
Cont : StKind → U
|
||
Cont e = JSExp -> JSStmt e
|
||
|
||
-- JSEnv contains `Var` for binders or `Dot` for destructured data. It
|
||
-- used to translate binders
|
||
record JSEnv where
|
||
constructor MkEnv
|
||
jsenv : List JSExp
|
||
depth : Int
|
||
|
||
-- this was like this, are we not using depth?
|
||
push : JSEnv -> JSExp -> JSEnv
|
||
push (MkEnv env depth) exp = MkEnv (exp :: env) depth
|
||
|
||
emptyJSEnv : JSEnv
|
||
emptyJSEnv = MkEnv Nil 0
|
||
|
||
litToJS : Literal -> JSExp
|
||
litToJS (LString str) = LitString str
|
||
litToJS (LChar c) = LitString $ pack (c :: Nil)
|
||
litToJS (LInt i) = LitInt i
|
||
|
||
-- Stuff nm.h1, nm.h2, ... into environment
|
||
-- TODO consider JSExp instead of nm, so we can have $foo.h1 instead of assigning a sc.
|
||
mkEnv : String -> Int -> JSEnv -> List String -> JSEnv
|
||
mkEnv nm k env Nil = env
|
||
mkEnv nm k env (x :: xs) = mkEnv nm (1 + k) (push env (Dot (Var nm) "h\{show k}")) xs
|
||
|
||
envNames : Env -> List String
|
||
|
||
-- given a name, find a similar one that doesn't shadow in Env
|
||
freshName : String -> JSEnv -> String
|
||
freshName nm env = if free env.jsenv nm then nm else go nm 1
|
||
where
|
||
free : List JSExp -> String -> Bool
|
||
free Nil nm = True
|
||
free (Var n :: xs) nm = if n == nm then False else free xs nm
|
||
free (_ :: xs) nm = free xs nm
|
||
|
||
go : String -> Int -> String
|
||
go nm k = let nm' = "\{nm}\{show k}" in if free env.jsenv nm' then nm' else go nm (1 + k)
|
||
|
||
freshName' : String -> JSEnv -> (String × JSEnv)
|
||
freshName' nm env =
|
||
let nm' = freshName nm env -- "\{nm}$\{show $ length env}"
|
||
env' = push env (Var nm')
|
||
in (nm', env')
|
||
|
||
freshNames : List String -> JSEnv -> (List String × JSEnv)
|
||
freshNames nms env = go nms env Lin
|
||
where
|
||
go : List Name -> JSEnv -> SnocList Name -> (List String × JSEnv)
|
||
go Nil env acc = (acc <>> Nil, env)
|
||
go (n :: ns) env acc =
|
||
let (n', env') = freshName' n env
|
||
in go ns env' (acc :< n')
|
||
|
||
|
||
|
||
|
||
-- This is inspired by A-normalization, look into the continuation monad
|
||
-- There is an index on JSStmt, adopted from Stefan Hoeck's code.
|
||
--
|
||
-- Here we turn a Term into a statement (which may be a sequence of statements), there
|
||
-- is a continuation, which turns the final JSExpr into a JSStmt, and the function returns
|
||
-- a JSStmt, wrapping recursive calls in JSnoc if necessary.
|
||
termToJS : ∀ e. JSEnv -> CExp -> Cont e -> JSStmt e
|
||
termToJS env (CBnd k) f = case getAt (cast k) env.jsenv of
|
||
(Just e) => f e
|
||
Nothing => fatalError "Bad bounds"
|
||
termToJS env CErased f = f JUndefined
|
||
termToJS env (CRaw str _) f = f (Raw str)
|
||
termToJS env (CLam nm t) f =
|
||
let (nm',env') = freshName' nm env -- "\{nm}$\{show $ length env}"
|
||
in f $ JLam (nm' :: Nil) (termToJS env' t JReturn)
|
||
termToJS env (CFun nms t) f =
|
||
let (nms', env') = freshNames nms env
|
||
in f $ JLam nms' (termToJS env' t JReturn)
|
||
termToJS env (CRef nm) f = f $ Var (show nm)
|
||
termToJS env (CPrimOp op t u) f = termToJS env t $ \ t => termToJS env u $ \ u => f $ JPrimOp op t u
|
||
termToJS env (CMeta k) f = f $ LitString "META \{show k}"
|
||
termToJS env (CLit lit) f = f (litToJS lit)
|
||
-- if it's a var, just use the original
|
||
termToJS env (CLet nm (CBnd k) u) f = case getAt (cast k) env.jsenv of
|
||
Just e => termToJS (push env e) u f
|
||
Nothing => fatalError "bad bounds"
|
||
termToJS env (CLet nm t u) f =
|
||
let nm' = freshName nm env
|
||
env' = push env (Var nm')
|
||
-- If it's a simple term, use const
|
||
in case termToJS env t (JAssign nm') of
|
||
(JAssign _ exp) => JSnoc (JConst nm' exp) (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 =
|
||
-- this shouldn't happen if where is lifted
|
||
let nm' = freshName nm env
|
||
env' = push env (Var nm')
|
||
-- If it's a simple term, use const
|
||
in case termToJS env' t (JAssign nm') of
|
||
(JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
|
||
t' => JSnoc (JLet nm' t') (termToJS env' u f)
|
||
termToJS env (CConstr nm args) f = go args 0 (\ args => f $ LitObject (("tag", LitString nm) :: args))
|
||
where
|
||
go : ∀ e. List CExp -> Int -> (List (String × JSExp) -> JSStmt e) -> JSStmt e
|
||
go Nil ix k = k Nil
|
||
go (t :: ts) ix k = termToJS env t $ \ t' => go ts (ix + 1) $ \ args => k $ ("h\{show ix}", t') :: args
|
||
termToJS env (CApp t args etas) f = termToJS env t (\ t' => (argsToJS t' args Lin f)) -- (f (Apply t' args'))))
|
||
where
|
||
etaExpand : JSEnv -> Nat -> SnocList JSExp -> JSExp -> JSExp
|
||
etaExpand env Z args tm = Apply tm (args <>> Nil)
|
||
etaExpand env (S etas) args tm =
|
||
let nm' = freshName "eta" env
|
||
env' = push env (Var nm')
|
||
in JLam (nm' :: Nil) $ JReturn $ etaExpand (push env (Var nm')) etas (args :< Var nm') tm
|
||
|
||
argsToJS : ∀ e. JSExp -> List CExp -> SnocList JSExp -> (JSExp -> JSStmt e) -> JSStmt e
|
||
argsToJS tm Nil acc k = k (etaExpand env (cast etas) acc tm)
|
||
-- k (acc <>> Nil)
|
||
argsToJS tm (x :: xs) acc k = termToJS env x (\ x' => argsToJS tm xs (acc :< x') k)
|
||
|
||
|
||
termToJS {e} env (CCase t alts) f =
|
||
-- need to assign the scrutinee to a variable (unless it is a var already?)
|
||
-- and add (Bnd -> JSExpr map)
|
||
-- TODO default case, let's drop the extra field.
|
||
|
||
termToJS env t $ \case
|
||
(Var nm) => maybeCaseStmt env nm alts
|
||
t' => do
|
||
-- TODO refactor nm to be a JSExp with Var{} or Dot{}
|
||
-- FIXME sc$ seemed to shadow something else, lets get this straightened out
|
||
-- we need freshName names that are not in env (i.e. do not play in debruijn)
|
||
let nm = "_sc$\{show env.depth}"
|
||
let env' = MkEnv env.jsenv (1 + env.depth)
|
||
JSnoc (JConst nm t') (maybeCaseStmt env' nm alts)
|
||
|
||
where
|
||
termToJSAlt : JSEnv -> String -> CAlt -> JAlt
|
||
termToJSAlt env nm (CConAlt name info args u) = JConAlt name (termToJS (mkEnv nm 0 env args) u f)
|
||
-- intentionally reusing scrutinee name here
|
||
termToJSAlt env nm (CDefAlt u) = JDefAlt (termToJS (env) u f)
|
||
termToJSAlt env nm (CLitAlt lit u) = JLitAlt (litToJS lit) (termToJS env u f)
|
||
|
||
maybeCaseStmt : JSEnv -> String -> List CAlt -> JSStmt e
|
||
-- If there is a single alt, assume it matched
|
||
maybeCaseStmt env nm ((CConAlt _ info args u) :: Nil) = (termToJS (mkEnv nm 0 env args) u f)
|
||
maybeCaseStmt env nm alts@(CLitAlt _ _ :: _) =
|
||
(JCase (Var nm) (map (termToJSAlt env nm) alts))
|
||
maybeCaseStmt env nm alts =
|
||
(JCase (Dot (Var nm) "tag") (map (termToJSAlt env nm) alts))
|
||
|
||
jsKeywords : List String
|
||
jsKeywords = (
|
||
"break" :: "case" :: "catch" :: "continue" :: "debugger" :: "default" :: "delete" :: "do" :: "else" ::
|
||
"finally" :: "for" :: "function" :: "if" :: "in" :: "instanceof" :: "new" :: "return" :: "switch" ::
|
||
"this" :: "throw" :: "try" :: "typeof" :: "var" :: "void" :: "while" :: "with" ::
|
||
"class" :: "const" :: "enum" :: "export" :: "extends" :: "import" :: "super" ::
|
||
"implements" :: "class" :: "let" :: "package" :: "private" :: "protected" :: "public" ::
|
||
"static" :: "yield" ::
|
||
"null" :: "true" :: "false" ::
|
||
-- might not be a big issue with namespaces on names now.
|
||
"String" :: "Number" :: "Array" :: "BigInt" :: Nil)
|
||
|
||
|
||
-- escape identifiers for js
|
||
jsIdent : String -> Doc
|
||
jsIdent id = if elem id jsKeywords then text ("$" ++ id) else text $ pack $ fix (unpack id)
|
||
where
|
||
fix : List Char -> List Char
|
||
fix Nil = Nil
|
||
fix (x :: xs) =
|
||
if isAlphaNum x || x == '_' then
|
||
x :: fix xs
|
||
-- make qualified names more readable
|
||
else if x == '.' then '_' :: fix xs
|
||
else if x == '$' then
|
||
'$' :: '$' :: fix xs
|
||
else
|
||
'$' :: (toHex (cast x)) ++ fix xs
|
||
|
||
|
||
|
||
stmtToDoc : ∀ e. JSStmt e -> Doc
|
||
|
||
|
||
expToDoc : JSExp -> Doc
|
||
expToDoc (LitArray xs) = fatalError "TODO - LitArray to doc"
|
||
expToDoc (LitObject xs) = text "{" <+> folddoc (\ a e => a ++ text ", " <+/> e) (map entry xs) <+> text "}"
|
||
where
|
||
entry : (String × JSExp) -> Doc
|
||
-- TODO quote if needed
|
||
entry (nm, exp) = jsIdent nm ++ text ":" <+> expToDoc exp
|
||
|
||
expToDoc (LitString str) = text $ quoteString str
|
||
expToDoc (LitInt i) = text $ show i
|
||
expToDoc (Raw str) = text str
|
||
-- TODO add precedence
|
||
expToDoc (Apply x@(JLam _ _) xs) = text "(" ++ expToDoc x ++ text ")" ++ text "(" ++ nest 2 (commaSep (map expToDoc xs)) ++ text ")"
|
||
expToDoc (Apply x xs) = expToDoc x ++ text "(" ++ nest 2 (commaSep (map expToDoc xs)) ++ text ")"
|
||
expToDoc (Var nm) = jsIdent nm
|
||
expToDoc (JLam nms (JReturn exp)) = text "(" <+> commaSep (map jsIdent nms) <+> text ") =>" <+> text "(" ++ expToDoc exp ++ text ")"
|
||
expToDoc (JLam nms body) = text "(" <+> commaSep (map jsIdent nms) <+> text ") =>" <+> bracket "{" (stmtToDoc body) "}"
|
||
expToDoc JUndefined = text "null"
|
||
expToDoc (Index obj ix) = expToDoc obj ++ text "(" ++ expToDoc ix ++ text " :: Nil)"
|
||
expToDoc (Dot obj nm) = expToDoc obj ++ text "." ++ jsIdent nm
|
||
expToDoc (JPrimOp op t u) = parens 0 1 (expToDoc t) <+> text op <+> parens 0 1 (expToDoc u)
|
||
|
||
caseBody : ∀ e. JSStmt e -> Doc
|
||
caseBody stmt@(JReturn x) = nest 2 (line ++ stmtToDoc stmt)
|
||
-- caseBody {e = Return} stmt@(JCase{}) = nest 2 (line ++ stmtToDoc stmt)
|
||
caseBody {e} stmt@(JCase _ _) = nest 2 (line ++ stmtToDoc stmt </> text "break;")
|
||
caseBody stmt = line ++ text "{" ++ nest 2 (line ++ stmtToDoc stmt </> text "break;") </> text "}"
|
||
|
||
altToDoc : JAlt -> Doc
|
||
altToDoc (JConAlt nm stmt) = text "case" <+> text (quoteString nm) ++ text ":" ++ caseBody stmt
|
||
altToDoc (JDefAlt stmt) = text "default" ++ text ":" ++ caseBody stmt
|
||
altToDoc (JLitAlt a stmt) = text "case" <+> expToDoc a ++ text ":" ++ caseBody stmt
|
||
|
||
stmtToDoc (JSnoc x y) = stmtToDoc x </> stmtToDoc y
|
||
stmtToDoc (JPlain x) = expToDoc x ++ text ";"
|
||
-- I might not need these split yet.
|
||
stmtToDoc (JLet nm body) = text "let" <+> jsIdent nm ++ text ";" </> stmtToDoc body
|
||
stmtToDoc (JAssign nm expr) = jsIdent nm <+> text "=" <+> expToDoc expr ++ text ";"
|
||
stmtToDoc (JConst nm x) = text "const" <+> jsIdent nm <+> nest 2 (text "=" <+/> expToDoc x ++ text ";")
|
||
stmtToDoc (JReturn x) = text "return" <+> expToDoc x ++ text ";"
|
||
stmtToDoc (JError str) = text "throw new Error(" ++ text (quoteString str) ++ text ");"
|
||
stmtToDoc (JCase sc alts) =
|
||
text "switch (" ++ expToDoc sc ++ text ")" <+> bracket "{" (stack $ map altToDoc alts) "}"
|
||
|
||
mkArgs : Nat -> List String -> List String
|
||
mkArgs Z acc = acc
|
||
mkArgs (S k) acc = mkArgs k ("h\{show k}" :: acc)
|
||
|
||
-- use iife to turn stmts into expr
|
||
maybeWrap : JSStmt Return -> JSExp
|
||
maybeWrap (JReturn exp) = exp
|
||
maybeWrap stmt = Apply (JLam Nil stmt) Nil
|
||
|
||
cexpToDoc : (QName × CExp) -> Doc
|
||
cexpToDoc (qn, ct) =
|
||
-- If we leak extra statements/assignments, we need an IIFE
|
||
let exp = maybeWrap $ termToJS emptyJSEnv ct JReturn
|
||
in stmtToDoc $ JConst (show qn) exp
|
||
|
||
-- Collect the QNames used in a term
|
||
getNames : Tm -> List QName -> List QName
|
||
getNames (Ref x nm) acc = nm :: acc
|
||
getNames (Lam x str _ _ t) acc = getNames t acc
|
||
getNames (App x t u) acc = getNames u $ getNames t acc
|
||
getNames (Pi x str icit y t u) acc = getNames u $ getNames t acc
|
||
getNames (Let x str t u) acc = getNames u $ getNames t acc
|
||
getNames (LetRec x str _ t u) acc = getNames u $ getNames t acc
|
||
getNames (Case x t alts) acc = foldl getAltNames acc alts
|
||
where
|
||
getAltNames : List QName -> CaseAlt -> List QName
|
||
getAltNames acc (CaseDefault t) = getNames t acc
|
||
getAltNames acc (CaseCons name args t) = name :: getNames t acc
|
||
getAltNames acc (CaseLit lit t) = getNames t acc
|
||
getNames _ acc = acc
|
||
|
||
-- returns a QName -> Def of in-use entries
|
||
-- This will be what we work on for optimization passes
|
||
getEntries : SortedMap QName Def → QName → M (SortedMap QName Def)
|
||
getEntries acc name = do
|
||
top <- getTop
|
||
case lookup name top of
|
||
Nothing => do
|
||
putStrLn "bad name \{show name}"
|
||
pure acc
|
||
Just (MkEntry _ name type def@(Fn exp) _) => case lookupMap' name acc of
|
||
Just _ => pure acc
|
||
Nothing =>
|
||
let acc = updateMap name def acc in
|
||
foldlM getEntries acc $ getNames exp Nil
|
||
Just (MkEntry _ name type def@(PrimFn _ _ used) _) =>
|
||
let acc = updateMap name def acc in
|
||
foldlM getEntries acc used
|
||
Just entry => pure $ updateMap name entry.def acc
|
||
|
||
-- sort names by dependencies
|
||
-- In JS this is only really needed for references that don't fall
|
||
-- under a lambda.
|
||
sortedNames : SortedMap QName CExp → QName → List QName
|
||
sortedNames defs qn = go Nil Nil qn
|
||
where
|
||
getBody : CAlt → CExp
|
||
getBody (CConAlt _ _ _ t) = t
|
||
getBody (CLitAlt _ t) = t
|
||
getBody (CDefAlt t) = t
|
||
|
||
getNames : List QName → CExp → List QName
|
||
getNames acc (CLam _ t) = getNames acc t
|
||
getNames acc (CFun _ t) = getNames acc t
|
||
getNames acc (CApp t ts _) = foldl getNames acc (t :: ts)
|
||
getNames acc (CCase t alts) = foldl getNames acc $ t :: map getBody alts
|
||
getNames acc (CRef qn) = qn :: acc
|
||
getNames acc (CLet _ t u) = getNames (getNames acc t) u
|
||
getNames acc (CLetRec _ t u) = getNames (getNames acc t) u
|
||
getNames acc (CConstr _ ts) = foldl getNames acc ts
|
||
getNames acc (CRaw _ deps) = deps ++ acc
|
||
-- wrote these out so I get an error when I add a new constructor
|
||
getNames acc (CLit _) = acc
|
||
getNames acc (CMeta _) = acc
|
||
getNames acc (CBnd _) = acc
|
||
getNames acc CErased = acc
|
||
getNames acc (CPrimOp op t u) = getNames (getNames acc t) u
|
||
|
||
go : List QName → List QName → QName → List QName
|
||
go loop acc qn =
|
||
-- O(n^2) it would be more efficient to drop qn from the map
|
||
if elem qn loop || elem qn acc then acc else
|
||
case lookupMap' qn defs of
|
||
Nothing => acc
|
||
Just exp => qn :: foldl (go $ qn :: loop) acc (getNames Nil exp)
|
||
|
||
eraseEntries : {{Ref2 Defs St}} → M Unit
|
||
eraseEntries = do
|
||
defs <- getRef Defs
|
||
ignore $ traverse go $ toList defs
|
||
where
|
||
go : {{Ref2 Defs St}} → (QName × Def) → M Unit
|
||
go (qn, Fn tm) = do
|
||
tm' <- erase Nil tm Nil
|
||
modifyRef Defs $ updateMap qn (Fn tm')
|
||
go _ = pure MkUnit
|
||
|
||
-- given a initial function, return a dependency-ordered list of javascript source
|
||
process : QName → M (List Doc)
|
||
process name = do
|
||
let wat = QN ("Prelude" :: Nil) "arrayToList"
|
||
top <- getTop
|
||
entries <- getEntries EmptyMap name
|
||
|
||
-- Maybe move this dance into liftWhere
|
||
ref <- newIORef entries
|
||
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
|
||
liftWhere
|
||
entries <- readIORef ref
|
||
exprs <- mapM defToCExp $ toList entries
|
||
let cexpMap = foldMap const EmptyMap exprs
|
||
cexpMap <- tailCallOpt cexpMap
|
||
let names = sortedNames cexpMap name
|
||
pure $ map cexpToDoc $ mapMaybe (\x => lookupMap x cexpMap) names
|
||
|
||
compile : M (List Doc)
|
||
compile = do
|
||
top <- getTop
|
||
case lookupRaw "main" top of
|
||
Just (MkEntry fc name type def _) => do
|
||
tmp <- process name
|
||
-- tack on call to main function
|
||
let exec = stmtToDoc $ JPlain $ Apply (Var $ show name) Nil
|
||
pure $ reverse (exec :: tmp)
|
||
Nothing =>
|
||
-- TODO maybe dump everything if there is no main
|
||
error emptyFC "No main function found"
|