ref: cb44db667ee863ebae46e5c1fe378dc7e7b829e0
parent: 75f35221224c8c5c4da65675125d99e05d60bc41
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Sep 20 20:23:23 EDT 2023
Fix bug in pattern match compilation.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.4
-871
-(($A :0 ((_663 _612) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _595)) ($K ($K (_807 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _21) (($B _716) (_703 (_655 "-v")))) ((_732 _655) "-r"))) (($B (_697 (($O 46) $K))) (($B _761) (_702 ((_721 _783) "-i")))))) (($B (_762 _728)) ((($C' _699) (($B _761) (_702 ((_721 _783) "-o")))) (($O "out.comb") $K))))) (_703 ((_763 _803) ((_763 (_655 (($O 45) $K))) (_714 1)))))) (_724 ((_763 _803) (_655 "--")))))) (($A :1 ((($S' ($S' _663)) _30) (($B ($B ($B (_663 _693)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _664)) ((($C' $B) (($B _762) (($B _683) ((($C' _798) _22) 0)))) (($B (_762 _686)) (($B (_699 "top level defns: ")) _643)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _664)) ((($C' $B) (($B _762) (($B _683) ((($C' _798) _22) 1)))) (_682 ($T (($B ($B (_762 _686))) ((($C' $B) (($B _699) ((($C' _699) _601) " = "))) (($C _421) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _23))) ((($S' $B) (($B ($C' ($C' _664))) ((($C' $B) ($B' (($B _762) (($B _688) _25)))) (($B _699) ((($C' _699) (($B (_699 _2)) _643)) (($O 10) $K)))))) (($B ($B (_663 _693))) ((($C' $B) ($B' (($B _762) (($B _683) ((($C' _798) _22) 0))))) (($B ($B (_762 _686))) ((($C' ($C' _699)) (($B ($B (_699 "final pass "))) (($B ($B (_657 6))) (($B ($B _643)) _792)))) "ms"))))))) _16))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _704)) _421))) (($C _717) (_733 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _763) (($B _699) ((($C' _699) (($B (_699 "(($A :")) _643)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _763)) ($B _421))) (($B (_763 (_699 ") "))) (($C _763) (_699 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _396)) $I))) ($BK $K))) $K))))) (($B (($S' _762) (($B _759) (($B (_762 _807)) (($B (_699 "main: findIdent: ")) _601))))) (($C' _631) _598)))) _638))) (($B ($B _635)) (($B (($C' _701) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _598))) $K)))))) (($C _717) (_733 0))))))) (($C _604) (_595 "main")))) (($B (_762 _395)) (($B (_762 _595)) (($B (_699 (($O 95) $K))) _643))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_664 (_686 "Type ':quit' to quit"))) ((($C' _663) (($B (_569 _5)) ($P _4))) ($K (_665 _809))))) (($A :4 ((_699 ((_699 ((_699 ((_699 "module ") _6)) "(module ")) _6)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_570 ((_762 _579) ((_13 ".mhsi") "> "))) (($P _5) (($C (($S (($C _655) ":quit")) ((($C' _571) _9) _5))) ((_762 _579) (_686 "Bye")))))) (($A :6 "Interactive") (($A :7 "_it") (($A :8 ((($C' _699) (_699 ((_699 ((_699 ((_699 _7) " :: Any\10&")) _7)) " = unsafeCoerce ("))) (($O 41) $K))) (($A :9 (($B (_570 _578)) (($B $T) ((($S' ($S' $B)) (($B ($B _570)) (($B ($B _10)) (($B (($C' _699) (($C _699) (($O 10) $K)))) _8)))) ((($C' ($C' ($C' $P))) (($B ($B $BK)) (($B ($B (($C' (($S' _570) _10)) (($B ($B ($P (($B (_762 _579)) _686)))) (($B $BK) (($B ($B _577)) ($C $P))))))) (($C' _699) (($C _699) (($O 10) $K)))))) _11))))) (($A :10 ((($C' _571) (($B (_762 _579)) (_688 ((_699 _6) ".hs")))) ((_570 (_574 _771)) ((($C' _570) (($B (_762 _579)) (($C _30) (_595 _6)))) (($B _572) _774))))) (($A :11 (($B (($B (_762 _579)) (($S (($C _867) (_686 "Type must be Int or IO"))) (($B (_762 _686)) (($B (_762 _643)) _20))))) (($B _17) ($P (_595 ((_699 ((_699 _6) (($O 46) $K))) _7)))))) (($A :12 ((($C' _664) _684) ((_663 (((_15 (($P _696) _696)) $K) $K)) ($T ($K _665))))) (($A :13 ((($S' $B) (($B _663) (($C _676) _659))) (($B ($B (($C' _663) (($P (_665 _696)) ((($C' _663) _690) (($B ((($S' _695) _716) _665)) _652)))))\ No newline at end of file
+872
+(($A :0 ((_664 _613) (($B ((($S' ($C (($C (($C $S') _3)) ((($C' ($C' $P)) ((($C' $B) _1) _596)) ($K ($K (_808 "Usage: mhs [-v] [-r] [-iPATH] [-oFILE] [ModuleName]"))))))) (($S (($S ((($S' _21) (($B _717) (_704 (_656 "-v")))) ((_733 _656) "-r"))) (($B (_698 (($O 46) $K))) (($B _762) (_703 ((_722 _784) "-i")))))) (($B (_763 _729)) ((($C' _700) (($B _762) (_703 ((_722 _784) "-o")))) (($O "out.comb") $K))))) (_704 ((_764 _804) ((_764 (_656 (($O 45) $K))) (_715 1)))))) (_725 ((_764 _804) (_656 "--")))))) (($A :1 ((($S' ($S' _664)) _30) (($B ($B ($B (_664 _694)))) ((($C' ($C' ($C' $C))) ((($C' $B) (($B ($C' $C)) ((($C' ($S' ($C' $C'))) (($B ($B ($B $C))) ((($C' ($C' ($C' $C))) ((($C' ($C' ($C' ($C' $S')))) (($B ($B ($B ($B $C)))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($S' ($C' $S'))))) ((($C' ($C' ($C' ($C' ($C' $C'))))) ((($C' ($S' ($C' ($C' ($C' $C'))))) (($B ($B ($B ($B $B')))) ((($C' ($S' ($C' $B))) (($B ($B ($B $C))) ((($S' $B) ($B' (($B ($S' $C')) (($B $B') (($B ($B _665)) ((($C' $B) (($B _763) (($B _684) ((($C' _799) _22) 0)))) (($B (_763 _687)) (($B (_700 "top level defns: ")) _644)))))))) ((($S' ($C' $B)) (($B $B') (($B $B') (($B $B') (($B ($B _665)) ((($C' $B) (($B _763) (($B _684) ((($C' _799) _22) 1)))) (_683 ($T (($B ($B (_763 _687))) ((($C' $B) (($B _700) ((($C' _700) _602) " = "))) (($C _422) $K))))))))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' _23))) ((($S' $B) (($B ($C' ($C' _665))) ((($C' $B) ($B' (($B _763) (($B _689) _25)))) (($B _700) ((($C' _700) (($B (_700 _2)) _644)) (($O 10) $K)))))) (($B ($B (_664 _694))) ((($C' $B) ($B' (($B _763) (($B _684) ((($C' _799) _22) 0))))) (($B ($B (_763 _687))) ((($C' ($C' _700)) (($B ($B (_700 "final pass "))) (($B ($B (_658 6))) (($B ($B _644)) _793)))) "ms"))))))) _16))))) ($C $P)))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($C _705)) _422))) (($C _718) (_734 0)))) $K))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B (($C' $B) (($B _764) (($B _700) ((($C' _700) (($B (_700 "(($A :")) _644)) (($O 32) $K))))))) ((($C' $B) (($B ($C' _764)) ($B _422))) (($B (_764 (_700 ") "))) (($C _764) (_700 (($O 41) $K))))))))))) $T)) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _397)) $I))) ($BK $K))) $K))))) (($B (($S' _763) (($B _760) (($B (_763 _808)) (($B (_700 "main: findIdent: ")) _602))))) (($C' _632) _599)))) _639))) (($B ($B _636)) (($B (($C' _702) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _599))) $K)))))) (($C _718) (_734 0))))))) (($C _605) (_596 "main")))) (($B (_763 _396)) (($B (_763 _596)) (($B (_700 (($O 95) $K))) _644))))))) (($A :2 "v3.4\10&") (($A :3 (($B (_665 (_687 "Type ':quit' to quit"))) ((($C' _664) (($B (_570 _5)) ($P _4))) ($K (_666 _810))))) (($A :4 ((_700 ((_700 ((_700 ((_700 "module ") _6)) "(module ")) _6)) ") where\10&import Prelude\10&import Unsafe.Coerce\10&")) (($A :5 ((_571 ((_763 _580) ((_13 ".mhsi") "> "))) (($P _5) (($C (($S (($C $equal) ":quit")) ((($C' _572) _9) _5))) ((_763 _580) (_687 "Bye")))))) (($A :6 "Interactive") (($A :7 "_it") (($A :8 ((($C' _700) (_700 ((_700 ((_700 ((_700 _7) " :: Any\10&")) _7)) " = unsafeCoerce ("))) (($O 41) $K))) (($A :9 (($B (_571 _579)) (($B $T) ((($S' ($S' $B)) (($B ($B _571)) (($B ($B _10)) (($B (($C' _700) (($C _700) (($O 10) $K)))) _8)))) ((($C' ($C' ($C' $P))) (($B ($B $BK)) (($B ($B (($C' (($S' _571) _10)) (($B ($B ($P (($B (_763 _580)) _687)))) (($B $BK) (($B ($B _578)) ($C $P))))))) (($C' _700) (($C _700) (($O 10) $K)))))) _11))))) (($A :10 ((($C' _572) (($B (_763 _580)) (_689 ((_700 _6) ".hs")))) ((_571 (_575 _772)) ((($C' _571) (($B (_763 _580)) (($C _30) (_596 _6)))) (($B _573) _775))))) (($A :11 (($B (($B (_763 _580)) (($S (($C _868) (_687 "Type must be Int or IO"))) (($B (_763 _687)) (($B (_763 _644)) _20))))) (($B _17) ($P (_596 ((_700 ((_700 _6) (($O 46) $K))) _7)))))) (($A :12 ((($C' _665) _685) ((_664 (((_15 (($P _697) _697)) $K) $K)) ($T ($K _666))))) (($A :13 ((($S' $B) (($B _664) (($C _677) _660))) (($B ($B (($C' _664) (($P (_666 _697)) ((($C' _664) _691) (($B ((($S' _696) _717) _666)) _653)))\ No newline at end of file
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -70,7 +70,10 @@
let
vs = allVarsBind $ BFcn (mkIdent "") eqns
xs = take (length aps) $ newVars "q" vs
- ex = runS loc (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts alts, hasGuards alts) | Eqn ps alts <- eqns]
+ mkArm (Eqn ps alts) =
+ let ps' = map dsPat ps
+ in (ps', dsAlts alts, hasGuards alts || any hasLit ps')
+ ex = runS loc (vs ++ xs) (map Var xs) (map mkArm eqns)
in foldr Lam ex xs
_ -> impossible
@@ -78,6 +81,14 @@
hasGuards (EAlts [([], _)] _) = False
hasGuards _ = True
+hasLit :: EPat -> Bool
+hasLit (ELit _ _) = True
+hasLit (EVar _) = False
+hasLit (ECon _) = False
+hasLit (EApp f a) = hasLit f || hasLit a
+hasLit (EAt _ p) = hasLit p
+hasLit _ = impossible
+
dsAlts :: EAlts -> (Exp -> Exp)
dsAlts (EAlts alts bs) = dsBinds bs . dsAltsL alts
@@ -204,7 +215,8 @@
let
vs = allVarsExpr (ELam ps e)
xs = take (length ps) (newVars "l" vs)
- ex = runS loc (vs ++ xs) (map Var xs) [(map dsPat ps, dsAlts $ oneAlt e, False)]
+ ps' = map dsPat ps
+ ex = runS loc (vs ++ xs) (map Var xs) [(ps', dsAlts $ oneAlt e, any hasLit ps')]
in foldr Lam ex xs
-- Handle special syntax for lists and tuples
@@ -268,7 +280,11 @@
dsCase :: SLoc -> Expr -> [ECaseArm] -> Exp
dsCase loc ae as =
- runS loc (allVarsExpr (ECase ae as)) [dsExpr ae] [([dsPat p], dsAlts alts, hasGuards alts) | (p, alts) <- as]
+ runS loc (allVarsExpr (ECase ae as)) [dsExpr ae] (map mkArm as)
+ where
+ mkArm (p, alts) =
+ let p' = dsPat p
+ in ([p'], dsAlts alts, hasGuards alts || hasLit p')
type MState = [Ident] -- supply of unused variables.
@@ -276,6 +292,9 @@
type Arm = ([EPat], Exp -> Exp, Bool) -- boolean indicates that the arm has guards
type Matrix = [Arm]
+--showArm :: Arm -> String
+--showArm (ps, _, b) = showList showExpr ps ++ "," ++ showBool b
+
newIdents :: Int -> M [Ident]
newIdents n = S.do
is <- get
@@ -379,7 +398,8 @@
eEqChar = Var $ mkIdent "Data.Char.eqChar"
eEqStr :: Exp
-eEqStr = Var $ mkIdent "Text.String.eqString"
+eEqStr = --Var $ mkIdent "Text.String.eqString"
+ Lit (LPrim "equal")
mkCase :: Exp -> [(SPat, Exp)] -> Exp -> Exp
mkCase var pes dflt =
@@ -423,7 +443,7 @@
loop xs [] = (reverse xs, [])
loop xs pps@(pg@(p:_, _, g) : rps) | not (isPVar p) = (reverse xs, pps)
| otherwise = if g then (reverse (pg:xs), rps)
- else loop (pg:xs) rps
+ else loop (pg:xs) rps
loop _ _ = impossible
(ds, rs) = loop [] nps
in (ps, ds, rs)
--
⑨