ref: aa1337f335e94ae3c83c59dea1e8a62a1be59fea
parent: 22433437b17a4da9f0681c8e89afa64caa0d9f21
author: Lennart Augustsson <lennart@augustsson.net>
date: Sat Sep 16 19:50:56 EDT 2023
Use SCC for let bindings.
--- a/Makefile
+++ b/Makefile
@@ -58,6 +58,7 @@
$(GHCC) -c lib/Unsafe/Coerce.hs
$(GHCC) -c lib/Data/Integer.hs
$(GHCC) -c lib/Control/Monad/State/Strict.hs
+# $(GHCC) -c lib/Debug/Trace.hs
$(GHCC) -c src/Text/ParserComb.hs
$(GHCC) -c src/MicroHs/Ident.hs
$(GHCC) -c src/MicroHs/Expr.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.3
-814
-(($A :0 ((_616 _569) (($B ((($S' ($C ((($C' ($S' _616)) (($B ($C _2)) _555)) (($B ($B (_616 _644))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _617)) ((($C' $B) (($B _711) (($B _634) ((($C' _749) _8) 0)))) (($B (_711 _637)) (($B (_650 "top level defns: ")) _598)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _617)) ((($C' $B) (($B _711) (($B _634) ((($C' _749) _8) 1)))) (_633 ($T (($B ($B (_711 _637))) ((($C' $B) (($B _650) ((($C' _650) _560) " = "))) _387)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _617))) ((($C' $B) ($B' (($B _711) (($B _639) _11)))) (($C' _650) ((($C' _650) (($B (_650 _1)) _598)) (($O 10) $K)))))) (($B ($B (_616 _644))) ((($C' $B) ($B' (($B _711) (($B _634) ((($C' _749) _8) 0))))) (($B ($B (_711 _637))) ((($C' ($C' _650)) (($B ($B (_650 "final pass "))) (($B ($B (_611 6))) (($B ($B _598)) _743)))) "ms"))))))) _3)))) _595))) (($B (($C' $C) (($B ($C _655)) _387))) (($C _668) (_685 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _650)))) (($B ($C' ($C' _650))) ((($C' ($C' ($C' _650))) (($B (($C' $B) (($B _650) ((($C' _650) (($B (_650 "(($A :")) _598)) (($O 32) $K))))) ($B _387))) ") "))) (($O 41) $K)))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _364)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _711) (($B _708) (($B (_711 _758)) (($B (_650 "main: findIdent: ")) _560))))) (($C' _588) _557)))) (($B ($B _592)) (($B (($C' _652) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _557))) $K)))))) (($C _668) (_685 0)))))) (($B (_711 _363)) (($B (_711 _555)) (($B (_650 (($O 95) $K))) _598)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _667) (_654 (_609 "-v")))) ((_684 _609) "-r"))) (($B (_648 (($O 46) $K))) (($B _710) (_653 ((_672 _734) "-i")))))) (($B (_711 _679)) ((($C' _650) (($B _710) (_653 ((_672 _734) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _745) _667) 1)) (_758 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _679)) (_654 ((_712 _754) ((_712 (_609 (($O 45) $K))) (_665 1))))))) (_675 ((_712 _754) (_609 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _616)) _16) (($B ($B ($B (_616 _644)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _617) (($B (_711 _635)) (($B (_711 (_666 1000000))) _187)))))) (($B ($B ($B ($B (_616 _644))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _617))) ((($C' $B) ($B' (($B _711) (($B _634) ((($C' _749) _8) 0))))) (($B ($B (_711 _637))) ((($C' ($C' _650)) (($B ($B (_650 "combinator conversion "))) (($B ($B (_611 6))) (($B ($B _598)) _743)))) "ms")))))) (($B ($B _618)) (($B $P) (($C _562) (_555 "main")))))))) (_652 ($T ((($C' ($C' $O)) ((($C' $B) $P) _390)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_616 _569)))) (($B ($B ($B (($C' _570) ((($C' _738) (($B _667) (_675 ((_712 _754) (_609 "--"))))) 1))))) (($B ($B ($B (_711 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _546))) (($C' ($C' _652)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _711) (($B _708) (($B (_711 _758)) (($B (_650 "not found ")) _560))))) ($C _547))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _389))) (($B (_711 (_708 (_758 "primlookup")))) (($C (_690 _609)) _5)))) $K))) (_758 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O
\ No newline at end of file
+817
+(($A :0 ((_619 _572) (($B ((($S' ($C ((($C' ($S' _619)) (($B ($C _2)) _557)) (($B ($B (_619 _647))) ((($C' ($C' $C)) ((($C' ($S' ($C' $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $S)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' $C))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($C' ($C' ($S' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($S' $B) ($B' ($B' (($B ($S' $B)) (($B ($B _620)) ((($C' $B) (($B _714) (($B _637) ((($C' _752) _8) 0)))) (($B (_714 _640)) (($B (_653 "top level defns: ")) _601)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _620)) ((($C' $B) (($B _714) (($B _637) ((($C' _752) _8) 1)))) (_636 ($T (($B ($B (_714 _640))) ((($C' $B) (($B _653) ((($C' _653) _562) " = "))) _389)))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _620))) ((($C' $B) ($B' (($B _714) (($B _642) _11)))) (($B _653) ((($C' _653) (($B (_653 _1)) _601)) (($O 10) $K)))))) (($B ($B (_619 _647))) ((($C' $B) ($B' (($B _714) (($B _637) ((($C' _752) _8) 0))))) (($B ($B (_714 _640))) ((($C' ($C' _653)) (($B ($B (_653 "final pass "))) (($B ($B (_614 6))) (($B ($B _601)) _746)))) "ms"))))))) _3))))) (($B (($C' $C) (($B ($C _658)) _389))) (($C _671) (_688 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) ((($C' ($C' ($C' ($C' _653)))) (($B ($C' ($C' _653))) ((($C' ($C' ($C' _653))) (($B (($C' $B) (($B _653) ((($C' _653) (($B (_653 "(($A :")) _601)) (($O 32) $K))))) ($B _389))) ") "))) (($O 41) $K)))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _365)) $I))) ($BK $K))) $K))))) (($B (($S' _714) (($B _711) (($B (_714 _761)) (($B (_653 "main: findIdent: ")) _562))))) (($C' _591) _559)))) _598))) (($B ($B _595)) ((($C' $B) (($B _655) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _559))) $K)))))) (($C _671) (_688 0))))))) ($T $A))) ($T $K))) $I)) (($B (_714 _364)) (($B (_714 _557)) (($B (_653 (($O 95) $K))) _601)))))))) (($S (($S ((($S' _7) (($B _670) (_657 (_612 "-v")))) ((_687 _612) "-r"))) (($B (_651 (($O 46) $K))) (($B _713) (_656 ((_675 _737) "-i")))))) (($B (_714 _682)) ((($C' _653) (($B _713) (_656 ((_675 _737) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _748) _670) 1)) (_761 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _682)) (_657 ((_715 _757) ((_715 (_612 (($O 45) $K))) (_668 1))))))) (_678 ((_715 _757) (_612 "--")))))) (($A :1 "v3.3\10&") (($A :2 ((($S' ($S' _619)) _16) (($B ($B ($B (_619 _647)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _620) (($B (_714 _638)) (($B (_714 (_669 1000000))) _187)))))) (($B ($B ($B ($B (_619 _647))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _620))) ((($C' $B) ($B' (($B _714) (($B _637) ((($C' _752) _8) 0))))) (($B ($B (_714 _640))) ((($C' ($C' _653)) (($B ($B (_653 "combinator conversion "))) (($B ($B (_614 6))) (($B ($B _601)) _746)))) "ms")))))) (($B ($B _621)) (($B $P) (($C _565) (_557 "main")))))))) (_655 ($T ((($C' ($C' $O)) ((($C' $B) $P) _392)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_619 _572)))) (($B ($B ($B (($C' _573) ((($C' _741) (($B _670) (_678 ((_715 _757) (_612 "--"))))) 1))))) (($B ($B ($B (_714 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _548))) (($C' ($C' _655)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _714) (($B _711) (($B (_714 _761)) (($B (_653 "not found ")) _562))))) ($C _549))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($S' $C)) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _391))) (($B (_714 (_711 (_761 "primlookup")))) (($C (_693 _612)) _5)))) $K))) (_761 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "
\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -6,7 +6,7 @@
LDef, showLDefs
) where
--import Debug.Trace
-import Prelude
+import Prelude --Xhiding(showList)
import Data.Char
import Data.List
import Data.Maybe
@@ -52,13 +52,12 @@
oneAlt :: Expr -> EAlts
oneAlt e = EAlts [([], e)] []
-dsBind :: EBind -> [LDef]
-dsBind abind =
+dsBind :: Ident -> EBind -> [LDef]
+dsBind v abind =
case abind of
BFcn f eqns -> [(f, dsEqns eqns)]
BPat p e ->
let
- v = newVar (allVarsBind abind)
de = (v, dsExpr e)
ds = [ (i, dsExpr (ECase (EVar v) [(p, oneAlt $ EVar i)])) | i <- patVars p ]
in de : ds
@@ -98,17 +97,24 @@
dsAlt dflt (SLet bs : ss) rhs = ELet bs (dsAlt dflt ss rhs)
dsBinds :: [EBind] -> Exp -> Exp
+dsBinds [] ret = ret
dsBinds ads ret =
- case ads of
- [] -> ret
- d:ds ->
- let
- dsd = dsBind d
- de = dsBinds ds ret
- def ir a =
- case ir of
- (i, r) -> App (Lam i a) (App (Lit (LPrim "Y")) (Lam i r))
- in foldr def de dsd
+ let
+ vs = newVars "q" $ concatMap allVarsBind ads
+ ds = concat $ zipWith dsBind vs ads
+ node ie@(i, e) = (ie, i, freeVars e)
+ gr = map node ds
+ asccs = stronglyConnComp leIdent gr
+ loop [] = ret
+ loop (AcyclicSCC (i, e) : sccs) =
+ let b = loop sccs
+ in App (Lam i b) e
+ loop (CyclicSCC [(i, e)] : sccs) =
+ let b = loop sccs
+ in App (Lam i b) (App (Lit (LPrim "Y")) (Lam i e))
+ loop (CyclicSCC ies : _sccs) =
+ error $ "Mutual recursion not implemented " ++ showList showIdent (map fst ies)
+ in loop asccs
dsExpr :: Expr -> Exp
dsExpr aexpr =
--- a/src/MicroHs/Exp.hs
+++ b/src/MicroHs/Exp.hs
@@ -4,7 +4,7 @@
module MicroHs.Exp(
compileOpt,
substExp,
- Exp(..), showExp, toStringP,
+ Exp(..), showExp, eqExp, toStringP,
PrimOp,
encodeString,
app2, cCons, cNil, cFlip,
@@ -14,7 +14,7 @@
import Data.Char
import Data.List
import MicroHs.Ident
-import MicroHs.Expr --X(Lit(..), showLit)
+import MicroHs.Expr --X(Lit(..), showLit, eqLit)
--Ximport Compat
--import Debug.Trace
@@ -26,6 +26,13 @@
| Lam Ident Exp
| Lit Lit
--Xderiving (Show, Eq)
+
+eqExp :: Exp -> Exp -> Bool
+eqExp (Var i1) (Var i2) = eqIdent i1 i2
+eqExp (App f1 a1) (App f2 a2) = eqExp f1 f2 && eqExp a1 a2
+eqExp (Lam i1 e1) (Lam i2 e2) = eqIdent i1 i2 && eqExp e1 e2
+eqExp (Lit l1) (Lit l2) = eqLit l1 l2
+eqExp _ _ = False
data MaybeApp = NotApp | IsApp Exp Exp
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -6,7 +6,7 @@
EDef(..), showEDefs,
Expr(..), showExpr,
Listish(..),
- Lit(..), showLit,
+ Lit(..), showLit, eqLit,
EBind(..),
Eqn(..),
EStmt(..),
@@ -286,70 +286,6 @@
SBind p e -> allVarsPat p ++ allVarsExpr e
SThen e -> allVarsExpr e
SLet bs -> concatMap allVarsBind bs
-
----------------------------------
-
-{- XXX Incomplete -freeVarsBind :: EBind -> [Ident]
-freeVarsBind abind =
- case abind of
- BFcn i eqns -> deleteAllBy eqIdent i (concatMap freeVarsEqn eqns)
- BPat p e -> deleteAllsBy eqIdent (allVarsPat p) (freeVarsExpr e)
-
-freeVarsEqn :: Eqn -> [Ident]
-freeVarsEqn eqn =
- case eqn of
- Eqn ps alts -> deleteAllsBy eqIdent (concatMap allVarsPat ps) (freeVarsAlts alts)
-
-freeVarsAlts :: EAlts -> [Ident]
-freeVarsAlts (EAlts alts bs) = concatMap freeVarsAlt alts ++ concatMap freeVarsBind bs
-
-freeVarsAlt :: EAlt -> [Ident]
-freeVarsAlt (ss, e) = concatMap freeVarsStmt ss ++ freeVarsExpr e
-
-freeVarsPat :: EPat -> [Ident]
-freeVarsPat = freeVarsExpr
-
-freeVarsExpr :: Expr -> [Ident]
-freeVarsExpr aexpr =
- case aexpr of
- EVar i -> [i]
- EApp e1 e2 -> freeVarsExpr e1 ++ freeVarsExpr e2
- EOper e1 ies -> freeVarsExpr e1 ++ concatMap (\ (i,e2) -> i : freeVarsExpr e2) ies
- ELam ps e -> concatMap freeVarsPat ps ++ freeVarsExpr e
- ELit _ _ -> []
- ECase e as -> freeVarsExpr e ++ concatMap freeVarsCaseArm as
- ELet bs e -> concatMap freeVarsBind bs ++ freeVarsExpr e
- ETuple es -> concatMap freeVarsExpr es
- EListish (LList es) -> concatMap freeVarsExpr es
- EDo mi ss -> maybe [] (:[]) mi ++ concatMap freeVarsStmt ss
- ESectL e i -> i : freeVarsExpr e
- ESectR i e -> i : freeVarsExpr e
- EIf e1 e2 e3 -> freeVarsExpr e1 ++ freeVarsExpr e2 ++ freeVarsExpr e3
- EListish l -> freeVarsListish l
- ESign e _ -> freeVarsExpr e
- EAt i e -> i : freeVarsExpr e
- EUVar _ -> []
- ECon c -> [conIdent c]
-
-freeVarsListish :: Listish -> [Ident]
-freeVarsListish (LList es) = concatMap freeVarsExpr es
-freeVarsListish (LCompr e ss) = freeVarsExpr e ++ concatMap freeVarsStmt ss
-freeVarsListish (LFrom e) = freeVarsExpr e
-freeVarsListish (LFromTo e1 e2) = freeVarsExpr e1 ++ freeVarsExpr e2
-freeVarsListish (LFromThen e1 e2) = freeVarsExpr e1 ++ freeVarsExpr e2
-freeVarsListish (LFromThenTo e1 e2 e3) = freeVarsExpr e1 ++ freeVarsExpr e2 ++ freeVarsExpr e3
-
-freeVarsCaseArm :: ECaseArm -> [Ident]
-freeVarsCaseArm (p, alts) = freeVarsPat p ++ freeVarsAlts alts
-
-freeVarsStmt :: EStmt -> [Ident]
-freeVarsStmt astmt =
- case astmt of
- SBind p e -> freeVarsPat p ++ freeVarsExpr e
- SThen e -> freeVarsExpr e
- SLet bs -> concatMap freeVarsBind bs
--}
-----------------------------
--- a/src/MicroHs/Graph.hs
+++ b/src/MicroHs/Graph.hs
@@ -37,7 +37,7 @@
-- in any cycle.
| CyclicSCC [vertex] -- ^ A maximal set of mutually
-- reachable vertices.
- --deriving (Eq, Show)
+ --Xderiving (Show)
stronglyConnComp
:: forall key node .
--- a/src/MicroHs/Ident.hs
+++ b/src/MicroHs/Ident.hs
@@ -1,7 +1,7 @@
module MicroHs.Ident(
Line, Col, Loc,
Ident(..),
- mkIdent, mkIdentLoc, unIdent, eqIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
+ mkIdent, mkIdentLoc, unIdent, eqIdent, leIdent, qualIdent, showIdent, getSLocIdent, setSLocIdent,
isLower_, isIdentChar, isOperChar, isConIdent,
unQualString,
SLoc(..), noSLoc, showSLoc
@@ -43,6 +43,9 @@
eqIdent :: Ident -> Ident -> Bool
eqIdent (Ident _ i) (Ident _ j) = eqString i j
+
+leIdent :: Ident -> Ident -> Bool
+leIdent (Ident _ i) (Ident _ j) = leString i j
qualIdent :: Ident -> Ident -> Ident
qualIdent (Ident loc qi) (Ident _ i) = Ident loc (qi ++ "." ++ i)
--
⑨