Skip to content

Commit 90c3807

Browse files
aslanixaslanix
committed
wip: extending the IR to special-case self-referenced functions
1 parent e404c73 commit 90c3807

File tree

5 files changed

+166
-76
lines changed

5 files changed

+166
-76
lines changed

‎compiler/src/ClosureConv.hs‎

Lines changed: 26 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,7 @@ type CC = RWS
4545
FreshCounter -- state: the counter for fresh name generation
4646

4747

48-
type CCEnv = (CompileMode, C.Atoms, NestingLevel, Map VarName VarLevel)
48+
type CCEnv = (CompileMode, C.Atoms, NestingLevel, Map VarName VarLevel, Maybe VarName)
4949
type Frees = [(VarName, NestingLevel)]
5050
type FunDefs = [CCIR.FunDef]
5151
type ConstEntry = (VarName, C.Lit)
@@ -59,11 +59,12 @@ consBB:: CCIR.IRInst -> CCIR.IRBBTree -> CCIR.IRBBTree
5959
consBB i (BB insts t) = BB (i:insts) t
6060

6161
insVar :: VarName -> CCEnv -> CCEnv
62-
insVar vn (compileMode, atms, lev, vmap) =
62+
insVar vn (compileMode, atms, lev, vmap, fname) =
6363
( compileMode
6464
, atms
6565
, lev
6666
, Map.insert vn (VarNested lev) vmap
67+
, fname
6768
)
6869

6970
insVars :: [VarName] -> CCEnv -> CCEnv
@@ -72,12 +73,12 @@ insVars vars ccenv =
7273

7374

7475
askLev = do
75-
(_, _, lev, _) <- ask
76+
(_, _, lev, _, _) <- ask
7677
return lev
7778

7879

79-
incLev (compileMode, atms, lev, vmap) =
80-
(compileMode, atms, lev + 1, vmap)
80+
incLev fname (compileMode, atms, lev, vmap, _) =
81+
(compileMode, atms, lev + 1, vmap, (Just fname))
8182

8283

8384
-- this helper function looks up the variable name
@@ -86,32 +87,35 @@ incLev (compileMode, atms, lev, vmap) =
8687

8788
transVar :: VarName -> CC VarAccess
8889
transVar v@(VN vname) = do
89-
(_, C.Atoms atms, lev, vmap) <- ask
90-
case Map.lookup v vmap of
91-
Just (VarNested lev') ->
92-
if lev' < lev
93-
then do
94-
tell $ ([], [(v, lev')], []) -- collecting info about free vars
95-
return $ VarEnv v
96-
else
97-
return $ VarLocal v
98-
Nothing ->
99-
if vname `elem` atms
100-
then return $ VarLocal v
101-
else error $ "undeclared variable: " ++ (show v)
90+
(_, C.Atoms atms, lev, vmap, maybe_fname) <- ask
91+
case maybe_fname of
92+
Just fname | fname == v -> return $ VarFunSelfRef
93+
_ ->
94+
case Map.lookup v vmap of
95+
Just (VarNested lev') ->
96+
if lev' < lev
97+
then do
98+
tell $ ([], [(v, lev')], []) -- collecting info about free vars
99+
return $ VarEnv v
100+
else
101+
return $ VarLocal v
102+
Nothing ->
103+
if vname `elem` atms
104+
then return $ VarLocal v
105+
else error $ "undeclared variable: " ++ (show v)
102106

103107

104108
transVars = mapM transVar
105109

106110
isDeclaredEarlierThan lev (_, l) = l < lev
107111

108-
transFunDec (VN fname) (CPS.Unary var kt) = do
112+
transFunDec f@(VN fname) (CPS.Unary var kt) = do
109113
lev <- askLev
110114
let filt = isDeclaredEarlierThan lev
111115
(bb, (_, frees, consts_wo_levs)) <-
112116
censor (\(a,b,c ) -> (a, filter filt b, filter (\(_, l) -> l == lev ) c))
113117
$ listen
114-
$ local ((insVar var) . incLev)
118+
$ local ((insVar var) . (incLev f))
115119
$ cpsToIR kt
116120
let consts = (fst.unzip) consts_wo_levs
117121
tell ([FunDef (HFN fname) var consts bb], [], [])
@@ -217,7 +221,7 @@ cpsToIR (CPS.LetFun fdefs kt) = do
217221
-- Special Halt continuation, for exiting program
218222
cpsToIR (CPS.Halt v) = do
219223
v' <- transVar v
220-
(compileMode,_ , _ , _ ) <- ask
224+
(compileMode,_ , _ , _, _ ) <- ask
221225
let constructor =
222226
case compileMode of
223227
Normal -> CCIR.Ret
@@ -265,6 +269,7 @@ closureConvert compileMode (CPS.Prog (C.Atoms atms) t) =
265269
, atms'
266270
, 0 -- initial nesting counter
267271
, Map.empty
272+
, Nothing -- top level code has no function name
268273
)
269274
initState = 0
270275
(bb, (fdefs, _, consts_wo_levs)) = evalRWS (cpsToIR t) initEnv initState

‎compiler/src/IR.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,8 @@ data VarAccess
4040
= VarLocal VarName
4141
-- | Variable defined in the closure.
4242
| VarEnv VarName
43+
-- | Variable refering to the very function being declared.
44+
| VarFunSelfRef
4345
deriving (Eq, Show, Generic)
4446

4547
type Ident = String
@@ -478,7 +480,7 @@ ppVarName (VN vn) = text vn
478480
ppVarAccess :: VarAccess -> PP.Doc
479481
ppVarAccess (VarLocal vn) = ppVarName vn
480482
ppVarAccess (VarEnv vn) = text "$env." PP.<> (ppVarName vn)
481-
483+
ppVarAccess (VarFunSelfRef) = text "<fun-self-ref>"
482484

483485
class Identifier a where
484486
ppId :: a -> PP.Doc

‎compiler/src/IROpt.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ idSubst = Subst (Map.empty)
2828

2929
instance Substitutable VarAccess where
3030
apply _ x@(VarEnv _) = x
31+
apply _ x@(VarFunSelfRef) = x
3132
apply subst@(Subst varmap) (VarLocal x) =
3233
Map.findWithDefault (VarLocal x) x varmap
3334

@@ -118,6 +119,7 @@ class PEval a where
118119

119120
markUsed x = tell $ Set.singleton x -- collect the use of the local
120121
markUsed' (VarEnv _) = return ()
122+
markUsed' (VarFunSelfRef) = return ()
121123
markUsed' (VarLocal x) = markUsed x
122124

123125
-- | Check if an expression can fail at runtime or has side effects
@@ -200,6 +202,7 @@ canFailOrHasEffects expr = case expr of
200202
-- | Get evaluation of a variable.
201203
varPEval :: VarAccess -> Opt PValue
202204
varPEval (VarEnv _) = return Unknown
205+
varPEval (VarFunSelfRef) = return Unknown
203206
varPEval (VarLocal x) = do
204207
env <- getEnv
205208
markUsed x

‎compiler/src/Stack2JS.hs‎

Lines changed: 124 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -8,15 +8,16 @@ TODO
88
99
--}
1010

11-
11+
{-# LANGUAGE FlexibleInstances #-}
12+
{-# LANGUAGE TypeSynonymInstances #-}
1213
{-# LANGUAGE OverloadedStrings #-}
1314
{-# LANGUAGE DeriveGeneric #-}
1415
{-# LANGUAGE LambdaCase #-}
1516
module Stack2JS where
1617
-- import qualified IR2JS
1718

1819
import IR (SerializationUnit(..), HFN(..)
19-
, ppId, ppFunCall, ppArgs, Fields (..), Ident
20+
, ppFunCall, ppArgs, Fields (..), Ident
2021
, serializeFunDef
2122
, serializeAtoms )
2223
import qualified Data.ByteString.Lazy.Char8 as BL
@@ -115,6 +116,35 @@ initState = TheState { freshCounter = 0
115116

116117
a $$+ b = a $$ (nest 2 b)
117118

119+
120+
121+
class Identifier a where
122+
ppId :: a -> PP.Doc
123+
124+
125+
instance Identifier VarName where
126+
ppId = IR.ppVarName
127+
128+
-- instance Identifier IR.VarAccess where
129+
-- ppId = IR.ppVarAccess
130+
131+
instance Identifier HFN where
132+
ppId (HFN n) = text n
133+
134+
instance Identifier Basics.LibName where
135+
ppId (Basics.LibName s) = text s
136+
137+
instance Identifier Basics.AtomName where
138+
ppId = text
139+
140+
instance Identifier RawVar where
141+
ppId (RawVar x) = text x
142+
143+
instance Identifier Raw.Assignable where
144+
ppId (Raw.AssignableRaw x) = ppId x
145+
ppId (Raw.AssignableLVal x) = ppId x
146+
ppId (Raw.Env) = text "$env"
147+
118148
-- | Translation monad collecting the generated JS parts when passing through the 'StackProgram' tree.
119149
class ToJS a where
120150
toJS :: a -> W PP.Doc
@@ -165,7 +195,16 @@ instance ToJS StackUnit where
165195
toJS (AtomStackUnit ca) = toJS ca
166196
toJS (ProgramStackUnit p) = error "not implemented"
167197

198+
instance ToJS IR.VarAccess where
199+
toJS (IR.VarLocal vn) = return $ IR.ppVarName vn
200+
toJS (IR.VarEnv vn) = return $ text "$env." PP.<> (IR.ppVarName vn)
201+
toJS (IR.VarFunSelfRef) = do
202+
HFN (fname) <- gets stHFN
203+
return $ text fname
204+
168205

206+
-- instance (Identifier a) => ToJS a where
207+
-- toJS x = return $ ppId x
169208

170209
ppNamespaceName = text "Top" -- should be generating a new namespace per received blob
171210

@@ -356,18 +395,28 @@ ir2js (StoreStack x i) = return $
356395
ir2js (MkFunClosures envBindings funBindings) = do
357396
-- Create new environment
358397
env <- freshEnvVar
398+
dd_env_ids <- ppEnvIds env envBindings
359399
let ppEnv = vcat [ semi $ hsep [ ppLet env
360400
, text "new rt.Env()"]
361-
, ppEnvIds env envBindings]
401+
, dd_env_ids]
362402
let ppFF = map (\(v, f) -> jsClosure v env f) funBindings
363403
return $ vcat (ppEnv : ppFF)
364404

365-
where ppEnvIds env ls =
366-
vcat (
367-
(map (\(a,b) -> semi $ (ppId env) PP.<> text "." PP.<> (ppId a) <+> text "=" <+> ppId b ) ls)
368-
++
369-
[ppId env PP.<> text ".__dataLevel = " <+> jsFunCall (text $ binOpToJS Basics.LatticeJoin) (map (\(_, b) -> ppId b <> text ".dataLevel") ls ) ]
370-
)
405+
where ppEnvIds :: VarName -> [(VarName, IR.VarAccess)] -> W PP.Doc
406+
ppEnvIds env ls = do
407+
let penv = ppId env
408+
d1 <- mapM (\(a,b) -> do
409+
d_b <- toJS b
410+
return $ semi $ penv PP.<> text "." PP.<> (ppId a) <+> text "=" <+> d_b
411+
)
412+
ls
413+
d3 <- mapM (\(_, b) -> do
414+
d_b <- toJS b
415+
return $ d_b <> text ".dataLevel") ls
416+
let d2 = penv PP.<> text ".__dataLevel = "
417+
<+> jsFunCall (text $ binOpToJS Basics.LatticeJoin) d3
418+
419+
return $ vcat ( d1 ++ [d2])
371420
hsepc ls = semi $ PP.hsep (PP.punctuate (text ",") ls)
372421

373422

@@ -480,8 +529,9 @@ tr2js (Error va pos) = return $
480529
tr2js (TailCall va1 ) = return $
481530
"return" <+> ppId va1
482531

483-
tr2js (LibExport va) = return $
484-
jsFunCall (text "return") [ppId va]
532+
tr2js (LibExport va) = do
533+
d <- toJS va
534+
return $ jsFunCall (text "return") [d]
485535

486536

487537
monStateToJs c =
@@ -507,52 +557,72 @@ ppSparseSlot = do
507557
-----------------------------------------------------------
508558

509559

510-
ppField :: IR.Identifier a => (String, a) -> PP.Doc
511-
ppField (f, v) = PP.brackets $ PP.quotes (text f) <> text "," <> ppId v
560+
fieldToJS :: ToJS a => (String, a) -> W PP.Doc
561+
fieldToJS (f, v) = do
562+
d <- toJS v
563+
return $ PP.brackets $ PP.quotes (text f) <> text "," <> d
512564

513-
ppFields :: IR.Identifier a => [(String, a)] -> [PP.Doc]
514-
ppFields fs = PP.punctuate (text ",") (map ppField fs)
565+
fieldsToJS :: ToJS a => [(String, a)] -> W [PP.Doc]
566+
fieldsToJS fs = do
567+
dd <- mapM fieldToJS fs
568+
return $ PP.punctuate (text ",") dd
515569

516570
instance ToJS RawExpr where
517-
toJS = \case
518-
ProjectState c -> return $ monStateToJs c
519-
e@(ProjectLVal _ _) -> return $ ppRawExpr e
520-
Bin binop va1 va2 -> return $
521-
let text' = (text . binOpToJS) binop in
522-
if isInfixBinop binop
523-
then hsep [ ppId va1, text', ppId va2 ]
524-
else jsFunCall text' [ppId va1, ppId va2]
525-
Un op v -> return $ text (unaryOpToJS op) <> PP.parens (ppId v)
526-
Tuple vars -> return $
527-
text "rt.mkTuple" <> PP.parens (PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppId vars))
528-
Record fields -> return $
529-
PP.parens $ text "rt.mkRecord" <> PP.parens (PP.brackets $ PP.hsep $ ppFields fields)
530-
WithRecord r fields -> return $
531-
text "rt.withRecord" <> PP.parens (
532-
PP.hsep [ppId r, text ",", PP.brackets $ PP.hsep $ ppFields fields ])
533-
ProjField x f -> return $
534-
text "rt.getField" <> PP.parens (ppId x <> text "," <> PP.quotes (text f ) )
535-
ProjIdx x idx -> return $
536-
text "rt.raw_indexTuple" <> PP.parens (ppId x <> text "," <> text (show idx) )
537-
List vars -> return $
538-
PP.parens $ text "rt.mkList" <> PP.parens (PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppId vars))
539-
ListCons v1 v2 -> return $
540-
text "rt.cons" <> PP.parens (ppId v1 <> text "," <> ppId v2)
541-
Const C.LUnit -> return $ text "rt.__unitbase"
542-
Const (C.LLabel s) -> return $
543-
text "rt.mkV1Label" <> (PP.parens . PP.doubleQuotes) (text s)
544-
Const lit -> do
545-
case lit of
546-
C.LAtom atom -> tell ([], [atom], [])
547-
_ -> return ()
548-
return $ ppLit lit
549-
Lib lib'@(Basics.LibName libname) varname -> do
550-
tell ([LibAccess lib' varname], [], [])
551-
return $
552-
text "rt.loadLib" <> PP.parens ((PP.quotes.text) libname <> text ", " <> (PP.quotes.text) varname <> text ", this")
553-
ConstructLVal r1 r2 r3 -> return $
554-
ppFunCall (text "rt.constructLVal") (map ppId [r1,r2,r3])
555-
Base b -> return $ text "rt." <+> text b -- Note: The "$$authorityarg" case is handled in IR2Raw
571+
toJS x = do
572+
HFN (fname) <- gets stHFN
573+
let ppFunSelfRef = text "$env." PP.<> ppId fname
574+
let ppVarName IR.VarFunSelfRef = ppFunSelfRef
575+
ppVarName x = IR.ppVarAccess x
576+
577+
case x of
578+
ProjectState c -> return $ monStateToJs c
579+
ProjectLVal IR.VarFunSelfRef lf -> return (
580+
case lf of
581+
Raw.FieldValue -> ppFunSelfRef PP.<>
582+
text "." PP.<> PP.text (show Raw.FieldValue)
583+
Raw.FieldValLev -> monStateToJs MonPC
584+
Raw.FieldTypLev -> monStateToJs MonPC)
585+
e@(ProjectLVal _ _) -> return $ ppRawExpr e
586+
Bin binop va1 va2 -> return $
587+
let text' = (text . binOpToJS) binop in
588+
if isInfixBinop binop
589+
then hsep [ ppId va1, text', ppId va2 ]
590+
else jsFunCall text' [ppId va1, ppId va2]
591+
Un op v -> return $ text (unaryOpToJS op) <> PP.parens (ppId v)
592+
Tuple vars -> return $
593+
text "rt.mkTuple" <> PP.parens (PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppVarName vars))
594+
Record fields -> do
595+
jsFields <- fieldsToJS fields
596+
return $
597+
PP.parens $ text "rt.mkRecord" <> PP.parens (PP.brackets $ PP.hsep $ jsFields )
598+
WithRecord r fields -> do
599+
jsFields <- fieldsToJS fields
600+
return $
601+
text "rt.withRecord" <> PP.parens (
602+
PP.hsep [ppId r, text ",", PP.brackets $ PP.hsep $ jsFields ])
603+
ProjField x f -> return $
604+
text "rt.getField" <> PP.parens (ppId x <> text "," <> PP.quotes (text f ) )
605+
ProjIdx x idx -> return $
606+
text "rt.raw_indexTuple" <> PP.parens (ppId x <> text "," <> text (show idx) )
607+
List vars -> return $
608+
PP.parens $ text "rt.mkList" <> PP.parens (PP.brackets $ PP.hsep $ PP.punctuate (text ",") (map ppVarName vars))
609+
ListCons v1 v2 -> return $
610+
text "rt.cons" <> PP.parens (ppVarName v1 <> text "," <> ppId v2)
611+
Const C.LUnit -> return $ text "rt.__unitbase"
612+
Const (C.LLabel s) -> return $
613+
text "rt.mkV1Label" <> (PP.parens . PP.doubleQuotes) (text s)
614+
Const lit -> do
615+
case lit of
616+
C.LAtom atom -> tell ([], [atom], [])
617+
_ -> return ()
618+
return $ ppLit lit
619+
Lib lib'@(Basics.LibName libname) varname -> do
620+
tell ([LibAccess lib' varname], [], [])
621+
return $
622+
text "rt.loadLib" <> PP.parens ((PP.quotes.text) libname <> text ", " <> (PP.quotes.text) varname <> text ", this")
623+
ConstructLVal r1 r2 r3 -> return $
624+
ppFunCall (text "rt.constructLVal") (map ppId [r1,r2,r3])
625+
Base b -> return $ text "rt." <+> text b -- Note: The "$$authorityarg" case is handled in IR2Raw
556626

557627

558628

‎tests/_unautomated/loop.trp‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
let
2+
fun loop n =
3+
if n <= 10 then
4+
let val _ = printWithLabels n
5+
in loop (n + 1)
6+
end
7+
else ()
8+
in
9+
loop 1
10+
end

0 commit comments

Comments
 (0)