ref: ffda7053c7418a374fe16ed1c7da8a024cfe7523
parent: f1136c9acb3b74f87a3bef4ca931564394a917f7
parent: 8fdde6a43838f7811ccfbd33635747e57b0d6eae
author: Lennart Augustsson <lennart@augustsson.net>
date: Mon Dec 23 09:24:30 EST 2024
Merge branch 'master' into patsyn3
--- a/Makefile
+++ b/Makefile
@@ -213,8 +213,8 @@
######
-VERSION=0.10.6.0
-HVERSION=0,10,6,0
+VERSION=0.10.7.0
+HVERSION=0,10,7,0
MCABAL=$(HOME)/.mcabal
MCABALMHS=$(MCABAL)/mhs-$(VERSION)
MDATA=$(MCABALMHS)/packages/mhs-$(VERSION)/data
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: MicroHs
-version: 0.10.6.0
+version: 0.10.7.0
-- *** When changing the version number, also
-- *** run 'sh updateversion.sh'
-- *** Yeah, it stinks.
@@ -42,8 +42,8 @@
src/runtime/*.c
src/runtime/*.h
-- I would like to have these two only for ghc, but I can't figure out how.
- lib/**/*.hs --NOT_MHS
- lib/**/*.hs-boot --NOT_MHS
+ lib/**/*.hs
+ lib/**/*.hs-boot
-- These files must not be installed for mhs!
-- Cabal doesn't seem to understand this, so it never copies
--- a/lib/libs.cabal
+++ b/lib/libs.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: libs
-version: 0.10.6.0
+version: 0.10.7.0
license: Apache
license-file: LICENSE
maintainer: lennart@augustsson.net
--- a/paths/Paths_MicroHs.hs
+++ b/paths/Paths_MicroHs.hs
@@ -10,4 +10,4 @@
getDataDir = return "."
version :: Version
-version = makeVersion [0,10,6,0]
+version = makeVersion [0,10,7,0]
--- a/src/MicroHs/Abstract.hs
+++ b/src/MicroHs/Abstract.hs
@@ -67,6 +67,15 @@
isP :: Exp -> Bool
isP = isPrim "P"
+isZ :: Exp -> Bool
+isZ = isPrim "Z"
+
+isK2 :: Exp -> Bool
+isK2 = isPrim "K2"
+
+isK3 :: Exp -> Bool
+isK3 = isPrim "K3"
+
cId :: Exp
cId = Lit (LPrim "I")
@@ -272,6 +281,12 @@
Lit (LPrim "R")
else if isCC ff && isB aa then
Lit (LPrim "C'B")
+ else if isZ ff && isK aa then
+ Lit (LPrim "K2")
+ else if isZ ff && isK2 aa then
+ Lit (LPrim "K3")
+ else if isZ ff && isK3 aa then
+ Lit (LPrim "K4")
else
let
def =
--- a/src/MicroHs/List.hs
+++ b/src/MicroHs/List.hs
@@ -12,12 +12,31 @@
elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool
elemBy eq a = any (eq a)
--- A simple "quicksort" for now.
+-- A simple merge sort for now.
sortLE :: forall a . (a -> a -> Bool) -> [a] -> [a]
-sortLE _ [] = []
-sortLE le (x:xs) = sortLE le lt ++ (x : sortLE le ge)
- where (ge, lt) = partition (le x) xs
+sortLE le = mergeAll . splatter
+ where
+ splatter [] = []
+ splatter [a] = [[a]]
+ splatter (a1 : a2 : as)
+ | a1 `le` a2 = [a1, a2] : splatter as
+ | otherwise = [a2, a1] : splatter as
+ mergeAll [] = []
+ mergeAll [xs] = xs
+ mergeAll xss = mergeAll (mergePairs xss)
+
+ mergePairs [] = []
+ mergePairs [xs] = [xs]
+ mergePairs (xs1 : xs2 : xss) = merge xs1 xs2 : mergePairs xss
+
+ merge [] ys = ys
+ merge xs [] = xs
+ merge axs@(x : xs) ays@(y : ys)
+ | x `le` y = x : merge xs ays
+ | otherwise = y : merge axs ys
+
+
showListS :: (a -> String) -> [a] -> String
showListS sa arg =
let
@@ -36,6 +55,14 @@
anySameBy :: (a -> a -> Bool) -> [a] -> Bool
anySameBy _ [] = False
anySameBy eq (x:xs) = elemBy eq x xs || anySameBy eq xs
+
+anySameByLE :: (a -> a -> Bool) -> [a] -> Bool
+anySameByLE le = anySameAdj . sortLE le
+ where
+ anySameAdj (x1 : xs@(x2 : _))
+ | x2 `le` x1 = True
+ | otherwise = anySameAdj xs
+ anySameAdj _ = False
deleteAllBy :: forall a . (a -> a -> Bool) -> a -> [a] -> [a]
deleteAllBy _ _ [] = []
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -320,6 +320,8 @@
<|< mkPattern <$> (pKeyword "pattern" *> pPatSyn)
<|< PatternSign <$> (pKeyword "pattern" *> (esepBy1 pUIdentSym (pSpec ',')) <* dcolon) <*> pType
<|< Deriving <$> (pKeyword "deriving" *> pKeyword "instance" *> pType)
+ <|< noop <$ (pKeyword "type" <* pKeyword "role" <* pTypeIdentSym <*
+ (pKeyword "nominal" <|> pKeyword "phantom" <|> pKeyword "representational"))
where
pAssoc = (AssocLeft <$ pKeyword "infixl") <|< (AssocRight <$ pKeyword "infixr") <|< (AssocNone <$ pKeyword "infix")
dig (TInt _ ii) | 0 <= i && i <= 9 = Just i where i = fromInteger ii
@@ -333,6 +335,7 @@
clsSym = do s <- pUIdentSym; guard (unIdent s /= "()"); return s
mkPattern (lhs, pat, meqn) = Pattern lhs pat meqn
+ noop = Infix (AssocLeft, 0) [] -- harmless definition
pPatSyn :: P (LHS, EPat, Maybe [Eqn])
pPatSyn = do
@@ -405,7 +408,10 @@
pContext :: P [EConstraint]
pContext = (pCtx <* pDRArrow) <|< pure []
where
- pCtx = ((:[]) <$> pTypeApp)
+ pCtx = ((:[]) <$> pTypeApp)
+ <|> (eq <$> pTypeArg <*> pTilde <*> pTypeArg) -- A hack to allow a~b => ...
+ eq t1 i t2 = [eApp2 (EVar i) t1 t2]
+ pTilde = do i <- pQSymOper; guard (i == mkIdent "~"); return i
pDRArrow :: P ()
pDRArrow = pSymbol "=>" <|< pSymbol "\x21d2"
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -555,14 +555,6 @@
kTypeTypeTypeS :: EType
kTypeTypeTypeS = kArrow kType $ kArrow kType kType
--- (=>) :: Constraint -> Type -> Type
---kConstraintTypeTypeS :: EType
---kConstraintTypeTypeS = kArrow kConstraint $ kArrow kType kType
-
--- (~) :: Type -> Type -> Constraint
-kTypeTypeConstraintS :: EType
-kTypeTypeConstraintS = kArrow kType (kArrow kType kConstraint)
-
mkIdentB :: String -> Ident
mkIdentB = mkIdentSLoc builtinLoc
@@ -610,11 +602,16 @@
kv = EVar k
kk = IdKind k sKind
-- Tuples are polykinded since they need to handle both Type and Constraint
+ -- (,) :: forall k . k -> k -> k
+ -- etc.
tuple n =
let
i = tupleConstr builtinLoc n
in (i, [entry i $ EForall True [kk] $ foldr kArrow kv (replicate n kv)])
+ -- (=>) :: forall k . Constraint -> k -> k
kImplies = EForall True [kk] $ kConstraint `kArrow` (kv `kArrow` kv)
+ -- (~) :: forall k . k -> k -> Constraint
+ kTypeEqual = EForall True [kk] $ kv `kArrow` (kv `kArrow` kConstraint)
in
[
-- The function arrow et al are bothersome to define in Primitives, so keep them here.
@@ -621,7 +618,7 @@
-- But the fixity is defined in Primitives.
(mkIdentB "->", [entry identArrow kTypeTypeTypeS]),
(mkIdentB "=>", [entry identImplies kImplies]),
- (mkIdentB "~", [entry identTypeEq kTypeTypeConstraintS]),
+ (mkIdentB "~", [entry identTypeEq kTypeEqual]),
-- Primitives.hs uses the type [], and it's annoying to fix that.
-- XXX should not be needed
(identList, [entry identList kTypeTypeS]),
@@ -2332,7 +2329,7 @@
multCheck :: [Ident] -> T ()
multCheck vs =
- when (anySame vs) $ do
+ when (anySameByLE (<=) vs) $ do
let v = head vs
tcError (getSLoc v) $ "Multiply defined: " ++ showIdent v
--- a/src/runtime/eval.c
+++ b/src/runtime/eval.c
@@ -618,14 +618,15 @@
/* Needed during reduction */
NODEPTR intTable[HIGH_INT - LOW_INT];
-NODEPTR combFalse, combTrue, combUnit, combCons, combPair;
-NODEPTR combCC, combZ, combIOBIND, combIORETURN, combIOCCBIND;
+NODEPTR combK, combTrue, combUnit, combCons, combPair;
+NODEPTR combCC, combZ, combIOBIND, combIORETURN, combIOCCBIND, combB, combC;
NODEPTR combLT, combEQ, combGT;
-NODEPTR combShowExn, combU, combK2;
+NODEPTR combShowExn, combU, combK2, combK3;
NODEPTR combBININT1, combBININT2, combUNINT1;
NODEPTR combBINDBL1, combBINDBL2, combUNDBL1;
NODEPTR combBINBS1, combBINBS2;
NODEPTR comb_stdin, comb_stdout, comb_stderr;
+#define combFalse combK
/* One node of each kind for primitives, these are never GCd. */
/* We use linear search in this, because almost all lookups
@@ -814,15 +815,18 @@
//MARK(n) = MARKED;
SETTAG(n, primops[j].tag);
switch (primops[j].tag) {- case T_K: combFalse = n; break;
+ case T_K: combK = n; break;
case T_A: combTrue = n; break;
case T_I: combUnit = n; break;
case T_O: combCons = n; break;
case T_P: combPair = n; break;
case T_CC: combCC = n; break;
+ case T_B: combB = n; break;
+ case T_C: combC = n; break;
case T_Z: combZ = n; break;
case T_U: combU = n; break;
case T_K2: combK2 = n; break;
+ case T_K3: combK3 = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_RETURN: combIORETURN = n; break;
case T_IO_CCBIND: combIOCCBIND = n; break;
@@ -848,15 +852,18 @@
NODEPTR n = HEAPREF(heap_start++);
SETTAG(n, t);
switch (t) {- case T_K: combFalse = n; break;
+ case T_K: combK = n; break;
case T_A: combTrue = n; break;
case T_I: combUnit = n; break;
case T_O: combCons = n; break;
case T_P: combPair = n; break;
case T_CC: combCC = n; break;
+ case T_B: combB = n; break;
+ case T_C: combC = n; break;
case T_Z: combZ = n; break;
case T_U: combU = n; break;
case T_K2: combK2 = n; break;
+ case T_K3: combK3 = n; break;
case T_IO_BIND: combIOBIND = n; break;
case T_IO_RETURN: combIORETURN = n; break;
case T_IO_CCBIND: combIOCCBIND = n; break;
@@ -928,6 +935,7 @@
#if GCRED
int red_a, red_k, red_i, red_int, red_flip;
#endif
+int red_bb, red_k4, red_k3, red_k2, red_ccb, red_z, red_r;
//counter_t mark_depth;
//counter_t max_mark_depth = 0;
@@ -2973,7 +2981,8 @@
/* Reset stack pointer and return. */
#define RET do { goto ret; } while(0)/* Check that there are at least n arguments, return if not. */
-#define CHECK(n) do { if (stack_ptr - stk < (n)) RET; } while(0)+#define HASNARGS(n) (stack_ptr - stk >= (n))
+#define CHECK(n) do { if (!HASNARGS(n)) RET; } while(0) #define SETIND(n, x) do { SETTAG((n), T_IND); INDIR((n)) = (x); } while(0) #define GOIND(x) do { SETIND(n, (x)); goto ind; } while(0)@@ -3027,6 +3036,12 @@
case T_ARR: RET;
case T_BADDYN: ERR1("FFI unknown %s", CSTR(n));+ /*
+ * Some of these reductions, (e.g., Z x y = K (x y)) are there to avoid
+ * that increase in arity that some "optimizations" in Abstract.hs
+ * stop reductions from happening. This can be important for "full laziness".
+ * In practice, these reductions almost never happen, but there they are anyway. :)
+ */
case T_S: GCCHECK(2); CHKARG3; GOAP(new_ap(x, z), new_ap(y, z)); /* S x y z = x z (y z) */
case T_SS: GCCHECK(3); CHKARG4; GOAP(new_ap(x, new_ap(y, w)), new_ap(z, w)); /* S' x y z w = x (y w) (z w) */
case T_K: CHKARG2; GOIND(x); /* K x y = *x */
@@ -3035,17 +3050,31 @@
case T_I: CHKARG1; GOIND(x); /* I x = *x */
case T_Y: CHKARG1; GOAP(x, n); /* n@(Y x) = x n */
case T_B: GCCHECK(1); CHKARG3; GOAP(x, new_ap(y, z)); /* B x y z = x (y z) */
- case T_BB: GCCHECK(2); CHKARG4; GOAP(new_ap(x, y), new_ap(z, w)); /* B' x y z w = x y (z w) */
- case T_Z: CHKARG3; GOAP(x, y); /* Z x y z = x y */
+ case T_BB: if (!HASNARGS(4)) {+ GCCHECK(1); CHKARG2; red_bb++; GOAP(combB, new_ap(x, y)); } else { /* B' x y = B (x y) */+ GCCHECK(2); CHKARG4; GOAP(new_ap(x, y), new_ap(z, w)); } /* B' x y z w = x y (z w) */
+ case T_Z: if (!HASNARGS(3)) {+ GCCHECK(1); CHKARG2; red_z++; GOAP(combK, new_ap(x, y)); } else { /* Z x y = K (x y) */+ CHKARG3; GOAP(x, y); } /* Z x y z = x y */
case T_C: GCCHECK(1); CHKARG3; GOAP(new_ap(x, z), y); /* C x y z = x z y */
case T_CC: GCCHECK(2); CHKARG4; GOAP(new_ap(x, new_ap(y, w)), z); /* C' x y z w = x (y w) z */
case T_P: GCCHECK(1); CHKARG3; GOAP(new_ap(z, x), y); /* P x y z = z x y */
- case T_R: GCCHECK(1); CHKARG3; GOAP(new_ap(y, z), x); /* R x y z = y z x */
+ case T_R: if(!HASNARGS(3)) {+ GCCHECK(1); CHKARG2; red_r++; GOAP(new_ap(combC, y), x); } else { /* R x y = C y x */+ GCCHECK(1); CHKARG3; GOAP(new_ap(y, z), x); } /* R x y z = y z x */
case T_O: GCCHECK(1); CHKARG4; GOAP(new_ap(w, x), y); /* O x y z w = w x y */
- case T_K2: CHKARG3; GOIND(x); /* K2 x y z = *x */
- case T_K3: CHKARG4; GOIND(x); /* K3 x y z w = *x */
- case T_K4: CHECK(5); POP(5); n = TOP(-1); x = ARG(TOP(-5)); GOIND(x); /* K4 x y z w v = *x */
- case T_CCB: GCCHECK(2); CHKARG4; GOAP(new_ap(x, z), new_ap(y, w)); /* C'B x y z w = x z (y w) */
+ case T_K2: if (!HASNARGS(3)) {+ CHKARG2; red_k2++; GOAP(combK, x); } else { /* K2 x y = K x */+ CHKARG3; GOIND(x); } /* K2 x y z = *x */
+ case T_K3: if (!HASNARGS(4)) {+ CHKARG2; red_k3++; GOAP(combK2, x); } else { /* K3 x y = K2 x */+ CHKARG4; GOIND(x); } /* K3 x y z w = *x */
+ case T_K4: if (!HASNARGS(5)) {+ CHKARG2; red_k4++; GOAP(combK3, x); } else { /* K4 x y = K3 x */+ CHECK(5); POP(5); n = TOP(-1); x = ARG(TOP(-5)); GOIND(x); } /* K4 x y z w v = *x */
+ case T_CCB: if (!HASNARGS(4)) {+ GCCHECK(2); CHKARG3; red_ccb++; GOAP(new_ap(combB, new_ap(x, z)), y); } else { /* C'B x y z = B (x z) y */+ GCCHECK(2); CHKARG4; GOAP(new_ap(x, z), new_ap(y, w)); } /* C'B x y z w = x z (y w) */
/*
* Strict primitives require evaluating the arguments before we can proceed.
@@ -4202,6 +4231,7 @@
(double)gc_scan_time / 1000);
#if GCRED
PRINT(" GC reductions A=%d, K=%d, I=%d, int=%d flip=%d\n", red_a, red_k, red_i, red_int, red_flip);+ PRINT(" special reductions B'=%d K4=%d K3=%d K2=%d C'B=%d, Z=%d, R=%d\n", red_bb, red_k4, red_k3, red_k2, red_ccb, red_z, red_r);#endif
}
#endif /* WANT_STDIO */
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -77,6 +77,7 @@
$(TMHS) Bang && $(EVAL) > Bang.out && diff Bang.ref Bang.out
$(TMHS) MString && $(EVAL) > MString.out && diff MString.ref MString.out
$(TMHS) OrPat && $(EVAL) > OrPat.out && diff OrPat.ref OrPat.out
+ $(TMHS) PartRed && $(EVAL) > PartRed.out && diff PartRed.ref PartRed.out
$(TMHS) PatSyn && $(EVAL) > PatSyn.out && diff PatSyn.ref PatSyn.out
errtest:
--- /dev/null
+++ b/tests/PartRed.hs
@@ -1,0 +1,93 @@
+module PartRed where
+import Primitives
+
+k2 :: Int -> Int -> Int -> Int
+k2 x y z = x
+
+f2 :: Int -> Int
+f2 = k2 1 2
+
+k3 :: Int -> Int -> Int -> Int -> Int
+k3 x y z w = x
+
+f3 :: Int -> Int
+f3 = k3 1 2 3
+
+f32 :: Int -> Int -> Int
+f32 = k3 1 2
+
+k4 :: Int -> Int -> Int -> Int -> Int -> Int
+k4 x y z w v = x
+
+f4 :: Int -> Int
+f4 = k4 1 2 3 4
+
+f42 :: Int -> Int -> Int -> Int
+f42 = k4 1 2
+
+f43 :: Int -> Int -> Int
+f43 = k4 1 2 3
+
+
+-----
+
+type S a = (a->a, a->a)
+
+sInt :: S Int
+sInt = (id, primIntNeg)
+
+j :: S a -> (a -> a) -> a -> a
+j d x y = snd d (x y)
+
+k :: (Int -> Int) -> Int -> Int
+k = j sInt
+
+---
+
+c'b :: (Int -> Int -> Int) -> (Int -> Int) -> Int -> Int -> Int
+c'b x y z w = x z (y w)
+
+fc'b :: Int -> Int
+fc'b = c'b primIntAdd primIntNeg 99
+
+---
+
+cZ :: (Int -> Int) -> Int -> Int -> Int
+cZ x y z = x y
+
+fcZ :: Int -> Int
+fcZ = cZ primIntNeg 11
+
+---
+
+r :: Int -> (Int -> Int -> Int) -> Int -> Int
+r x y z = y z x
+
+fr :: Int -> Int
+fr = r 22 primIntAdd
+
+main :: IO ()
+main = do
+ cprint k2
+ cprint f2
+ cprint k3
+ cprint f3
+ cprint f32
+ cprint k4
+ cprint f4
+ cprint f42
+ cprint f43
+ --
+ cprint k
+ --
+ cprint c'b
+ cprint fc'b
+ --
+ cprint cZ
+ cprint fcZ
+ --
+ cprint r
+ cprint fr
+
+
+-- R x y = C y x
--- /dev/null
+++ b/tests/PartRed.ref
@@ -1,0 +1,16 @@
+K2
+(K #1)
+K3
+(K #1)
+(K2 #1)
+K4
+(K #1)
+(K3 #1)
+(K2 #1)
+(B neg)
+C'B
+((B (+ #99)) neg)
+Z
+(K #-11)
+R
+((C +) #22)