diff options
Diffstat (limited to 'compiler/ilxGen/tests')
34 files changed, 1630 insertions, 0 deletions
diff --git a/compiler/ilxGen/tests/Makefile b/compiler/ilxGen/tests/Makefile new file mode 100644 index 0000000000..423839c9e8 --- /dev/null +++ b/compiler/ilxGen/tests/Makefile @@ -0,0 +1,130 @@ + +TOP = ../../.. +include $(TOP)/mk/boilerplate.mk + +WAYS=$(GhcLibWays) + +#----------------------------------------------------------------------------- +# Setting the standard variables +# + +HC = $(GHC_INPLACE) +SRC_HC_OPTS+=-cpp -fglasgow-exts + +#----------------------------------------------------------------------------- +# +CORENV_DEBUG= +CORENV_RETAIL= +LOCALRUN=./ +ifeq ($(HOSTNAME),MSRC-HILDA) +CORENV_DEBUG="call devcorb2gen.bat checked" +CORENV_RETAIL="call devcorb2gen.bat free" +LOCALRUN=.\\ +endif + +ghc: + $(MAKE) -C ../.. + +ilx: + $(MAKE) -C $(ILX2IL_HOME) ilxdefault + +prel: ilx + $(MAKE) -C ../../../lib/std std.$(ilx_way).dll std.$(ilx_way).vlb + +#======================================================================== +# 1. From Haskell to ILX and then to IL - see build.mk + +#------------------------------------------------------------------------ +# 2. From IL to .EXE + +%.$(ilx_way).exe : %.$(ilx_way).il ../Entry.$(ilx_way).il + cat $*.$(ilx_way).il ../Entry.$(ilx_way).il > $@.tmp +# echo "call devcorb2gen free" > tmp.bat + echo "ilasm /DEBUG /QUIET /OUT=$@ $@.tmp" >> tmp.bat + cmd /c tmp.bat + +../Entry.$(hs2ilx_suffix)_o: ../Entry.ilx + sed -e "s|ilx std|ilx std.$(hs2ilx_suffix)|g" ../Entry.ilx > $@.tmp + mv $@.tmp $@ + + +%.$(ilx_way).mvl: %.$(ilx_way).il + (ILVALID_HOME=c:\\devel\\fcom\\src\\ ILVALID_MSCORLIB=mscorlib.vlb $(ILVALID) c:\\devel\\fcom\\src\\bin\\msilxlib$(ilx2il_suffix).vlb $(TOP)/lib/std/std.$(ilx_way).vlb $<) 2>&1 + + +#------------------------------------------------------------------------ +# From .HS to .EXE without using ILX +# Used to run performance comparisons against native code GHC + +%.Onot.exe: %.hs + $(GHC_INPLACE) -Onot -o $@ $< + +%.O.exe: %.hs + $(GHC_INPLACE) -O -o $@ $< + +WIN_TOP_ABS = $(subst /,\,$(FPTOOLS_TOP_ABS)) +WIN_ILX2IL_HOME = $(subst /,\,$(ILX2IL_HOME)) + +app.config: + echo "<configuration>" > $@ + echo "<runtime>" >> $@ + echo "<assemblyBinding xmlns=\"urn:schemas-microsoft-com:asm.v1\">" >> $@ + echo "<probing privatePath=\"$(WIN_TOP_ABS)\\ghc\\lib\\std;$(WIN_ILX2IL_HOME)\\bin\"/>" >> $@ + echo "</assemblyBinding>" >> $@ + echo "</runtime>" >> $@ + echo "</configuration>" >> $@ + +%.run: %.exe app.config + time -p $< + +#------------------------------------------------------------------------ +# Running: + +HSstd_cbits.dll: $(DLL_PEN)/HSstd_cbits.dll + cp $< $@ + +%.cordbg.run: HSstd_cbits.dll %.exe + cp app.config $@.config +# echo "call devcorb2gen fastchecked" > $@.bat + echo "$(LOCALRUN)$(subst /,\\,$*).exe 2>&1" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat + +%.debug.run: HSstd_cbits.dll %.exe + cp app.config $@.config +# echo "call devcorb2gen fastchecked" > $@.bat + echo "$(LOCALRUN)$(subst /,\\,$*).exe 2>&1" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat + +%.retail.run: HSstd_cbits.dll %.exe + cp app.config $@.config +# echo "call devcorb2gen free" > $@.bat + echo "$(LOCALRUN)$(subst /,\\,$*).exe 2>&1" >> $@.bat + time -p cmd /c $(subst /,\\,$@).bat + rm $@.bat + + +%.run: %.exe + time -p $< + + +#-------------------- + +%.mvl: %.nolib.il + ILVALID_HOME=$(ILX2IL_HOME) $(ILVALID) $*.nolib.il + +ci: + (cd $(ILX2IL_HOME); $(CVS) ci -m "") + (cd ../..; cvs ci -m "") + (cd ../../../lib/std; $(CVS) ci -m "") + +upd: + (cd $(ILX2IL_HOME); $(CVS) up) + (cd ../..; $(CVS) up) + (cd ../../../lib/std; $(CVS) up) + + +.PHONY: %.run + +include $(TOP)/mk/target.mk diff --git a/compiler/ilxGen/tests/PrelNum.hs b/compiler/ilxGen/tests/PrelNum.hs new file mode 100644 index 0000000000..ca23e149ff --- /dev/null +++ b/compiler/ilxGen/tests/PrelNum.hs @@ -0,0 +1,120 @@ + + + + + + + + + + + + + + + + +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} + +module PrelNum where + +import {-# SOURCE #-} PrelErr +import PrelBase +import PrelList +import PrelEnum +import PrelShow + +infixl 7 * +infixl 6 +, - + +default () -- Double isn't available yet, + -- and we shouldn't be using defaults anyway + + + + + + + + + +class (Eq a, Show a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + fromInt :: Int -> a -- partain: Glasgow extension + + x - y = x + negate y + negate x = 0 - x + fromInt (I# i#) = fromInteger (S# i#) + -- Go via the standard class-op if the + -- non-standard one ain't provided + + + + + +subtract :: (Num a) => a -> a -> a +{-# INLINE subtract #-} +subtract x y = y - x + +ord_0 :: Num a => a +ord_0 = fromInt (ord '0') + + + + + + + + + + +instance Num Int where + (+) x y = plusInt x y + (-) x y = minusInt x y + negate x = negateInt x + (*) x y = timesInt x y + abs n = if n `geInt` 0 then n else (negateInt n) + + signum n | n `ltInt` 0 = negateInt 1 + | n `eqInt` 0 = 0 + | otherwise = 1 + + fromInt n = n + + + + +-- These can't go in PrelBase with the defn of Int, because +-- we don't have pairs defined at that time! + +quotRemInt :: Int -> Int -> (Int, Int) +a@(I# _) `quotRemInt` b@(I# _) = (a `quotInt` b, a `remInt` b) + -- OK, so I made it a little stricter. Shoot me. (WDP 94/10) + +divModInt :: Int -> Int -> (Int, Int) +divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y) + -- Stricter. Sorry if you don't like it. (WDP 94/10) + + + + + + + + + + +data Integer + = S# Int# -- small integers + | J# Int# ByteArray# -- large integers + + + + + +zeroInteger :: Integer +zeroInteger = S# 0# + diff --git a/compiler/ilxGen/tests/build.mk b/compiler/ilxGen/tests/build.mk new file mode 100644 index 0000000000..285fd5de4e --- /dev/null +++ b/compiler/ilxGen/tests/build.mk @@ -0,0 +1,121 @@ +# 1. To make standard library: +# +# e.g. from lib/std directory: +# $(MAKE) way=ilx-Onot-mono std.ilx-Onot.mono.dll std.ilx-Onot.mono.vlb +# $(MAKE) way=ilx-O-mono std.ilx-O.mono.dll std.ilx-O.mono.vlb +# $(MAKE) way=ilx-Onot-generic std.ilx-Onot.generic.dll +# +# 2. To make tests: +# +# e.g. from ilxGen/tests directory: +# +# $ make -n way=ilx-Onot-mono test1.ilx-Onot.mono.retail.run +# +# $ make -n way=ilx-Onot-mono test1-nostdlib.ilx-Onot.mono.retail.run HC_OPTS="-fno-implicit-prelude -fglasgow-exts" +# + + +# Add all the ILX ways so dependencies get made correctly. +# (n.b. Actually we only need to add "ilx-Onot" and "ilx-O" for the +# GHC --> ILX dependencies, as these are the portions of the ILX +# ways that are relevant in terms of GHC options, +# but we list some of the others anyway. Also note that +# there are no dependencies required for the ILX --> IL or +# IL --> CLR phases as these operate on the "standalone" +# ILX and IL files). +# +#GhcLibWays+= ilx-Onot-mono ilx-Onot ilx-O ilx-O-mono +GhcLibWays+=i +GhcWithIlx=YES + +ILXized=YES + +GhcHcOpts+=-DILX -DNO_BIG_TUPLES +GhcLibHcOpts+=-optI--mono -optI--add-suffix-to-assembly -optImsilxlib -optI--suffix-to-add -optI.mono + +# Each set of args below defines one ILX way. +#ALL_WAYS+=ilx-Onot-generic +#WAY_ilx-Onot-generic_NAME=ILX with Haskell Optimizer Off to run on Generic CLR +#WAY_ilx-Onot-generic_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot +#WAY_ilx-Onot-generic_ILX2IL_OPTS=--generic +#WAY_ilx-Onot-generic_ILX=YES + +#ALL_WAYS+=ilx-Onot-fullgeneric-verifiable +#WAY_ilx-Onot-fullgeneric-verifiable_NAME=ILX with Haskell Optimizer Off to run on Generic CLR +#WAY_ilx-Onot-fullgeneric-verifiable_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot +#WAY_ilx-Onot-fullgeneric-verifiable_ILX2IL_OPTS=--fullgeneric --verifiable +#WAY_ilx-Onot-fullgeneric-verifiable_ILX=YES + +#ALL_WAYS+=ilx-Onot-repgeneric-verifiable +#WAY_ilx-Onot-repgeneric-verifiable_NAME=ILX with Haskell Optimizer Off to run on Generic CLR +#WAY_ilx-Onot-repgeneric-verifiable_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot +#WAY_ilx-Onot-repgeneric-verifiable_ILX2IL_OPTS=--repgeneric --verifiable +#WAY_ilx-Onot-repgeneric-verifiable_ILX=YES + +#ALL_WAYS+=ilx-O-generic +#WAY_ilx-O-generic_NAME=ILX with Haskell Optimizer On to run on Generic CLR +#WAY_ilx-O-generic_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O +#WAY_ilx-O-generic_ILX2IL_OPTS=--generic +#WAY_ilx-O-generic_ILX=YES + +#ALL_WAYS+=ilx-Onot-mono +#WAY_ilx-Onot-mono_NAME=ILX with Haskell Optimizer Off to run on V1 CLR +#WAY_ilx-Onot-mono_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot +#WAY_ilx-Onot-mono_ILX2IL_OPTS=--mono +#WAY_ilx-Onot-mono_ILX=YES + +#ALL_WAYS+=ilx-Onot-mono-verifiable +#WAY_ilx-Onot-mono-verifiable_NAME=ILX with Haskell Optimizer Off to run on V1 CLR, verifiable code (CURRENTLY WILL NOT RUN BECAUSE OF LACK OF HIGHER KINDED TYPE PARAMETERS BUT IS USEFUL TO FIND BUGS USING THE VERIFIER) +#WAY_ilx-Onot-mono-verifiable_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot +#WAY_ilx-Onot-mono-verifiable_ILX2IL_OPTS=--mono --verifiable +#WAY_ilx-Onot-mono-verifiable_ILX=YES + +#ALL_WAYS+=ilx-O-mono +#WAY_ilx-O-mono_NAME=ILX with Haskell Optimizer On to run on V1 CLR +#WAY_ilx-O-mono_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O +#WAY_ilx-O-mono_ILX2IL_OPTS=--mono +#WAY_ilx-O-mono_ILX=YES + +#ALL_WAYS+=ilx-Onot-generic-traced +#WAY_ilx-Onot-generic-traced_NAME=ILX with Haskell Optimizer Off to run on Generic CLR +#WAY_ilx-Onot-generic-traced_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot +#WAY_ilx-Onot-generic-traced_ILX2IL_OPTS=--generic --traced +#WAY_ilx-Onot-generic-traced_ILX=YES + +#ALL_WAYS+=ilx-O-generic-traced +#WAY_ilx-O-generic-traced_NAME=ILX with Haskell Optimizer On to run on Generic CLR +#WAY_ilx-O-generic-traced_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O +#WAY_ilx-O-generic-traced_ILX2IL_OPTS=--generic --traced +#WAY_ilx-O-generic-traced_ILX=YES + +#ALL_WAYS+=ilx-Onot-mono-traced +#WAY_ilx-Onot-mono-traced_NAME=ILX with Haskell Optimizer Off to run on V1 CLR +#WAY_ilx-Onot-mono-traced_HC_OPTS=-buildtag ilx-Onot $(GHC_ILX_OPTS) -Onot +#WAY_ilx-Onot-mono-traced_ILX2IL_OPTS=--mono --traced +#WAY_ilx-Onot-mono-traced_ILX=YES + +#ALL_WAYS+=ilx-O-mono-traced +#WAY_ilx-O-mono-traced_NAME=ILX with Haskell Optimizer On to run on V1 CLR +#WAY_ilx-O-mono-traced_HC_OPTS=-buildtag ilx-O $(GHC_ILX_OPTS) -O +#WAY_ilx-O-mono-traced_ILX2IL_OPTS=--mono --traced +#WAY_ilx-O-mono-traced_ILX=YES + +# Put a "." after the Haskell portion of the way. Way names can't contain +# dots for some reason elsewhere in the Make system. But we need to be able +# to split out the Haskell portion of the way from the ILX portion (e.g. --generic) +# and the runtime portion (e.g. --retail). +ilx_way=$(subst ilx-Onot-,ilx-Onot.,$(subst ilx-O-,ilx-O.,$(way))) +ilx2il_suffix=$(subst ilx-Onot.,.,$(subst ilx-O.,.,$(ilx_way))) +hs2ilx_suffix=$(subst $(ilx2il_suffix),,$(ilx_way)) +HS_ILX=$(subst $(way),$(hs2ilx_suffix),$(HS_OBJS)) +#HS_IL=$(subst $(hs2ilx_suffix)_o,$(ilx_way).il,$(HS_ILX)) +HS_IL=$(subst .o,.il,$(HS_ILX)) + +ILVALID=C:/devel/fcom/bin/ilvalid.exe +ILVERIFY=C:/devel/fcom/bin/ilverify.exe + +%.$(ilx_way).mvl : %.$(ilx_way).il $(HS_IL) + ((ILVALID_HOME=c:\\devel\\fcom\\src\\ ILVALID_MSCORLIB=mscorlib.vlb $(ILVALID) c:\\devel\\fcom\\src\\bin\\msilxlib$(ilx2il_suffix).vlb $(addprefix --other-il-module ,$(filter-out $*.$(ilx_way).il,$(HS_IL))) $<) 2>&1) | tee $@ + +%.$(ilx_way).mvr : %.$(ilx_way).il $(HS_IL) + ((ILVALID_HOME=c:\\devel\\fcom\\src\\ ILVALID_MSCORLIB=mscorlib.vlb $(ILVERIFY) c:\\devel\\fcom\\src\\bin\\msilxlib$(ilx2il_suffix).vlb $(addprefix --other-il-module ,$(filter-out $<,$(HS_IL))) $<) 2>&1) | tee $@ diff --git a/compiler/ilxGen/tests/foo.hs b/compiler/ilxGen/tests/foo.hs new file mode 100644 index 0000000000..d66608ba22 --- /dev/null +++ b/compiler/ilxGen/tests/foo.hs @@ -0,0 +1,9 @@ +{-# OPTIONS -fglasgow-exts #-} +module Foo where +import PrelGHC +import PrelNum +import PrelBase +integer2Intx :: Integer -> Int +integer2Intx (S# i) = I# i +integer2Intx (J# s d) = case (integer2Int# s d) of { n# -> I# n# } + diff --git a/compiler/ilxGen/tests/life.hs b/compiler/ilxGen/tests/life.hs new file mode 100644 index 0000000000..d6bcd16f9f --- /dev/null +++ b/compiler/ilxGen/tests/life.hs @@ -0,0 +1,360 @@ +-------------------------------- +-- The Game of Life -- +-------------------------------- + +generations x = 30 + +data L a = N | C1 a (L a) + +data Tuple2 a b = T2 a b + +data Tuple3 a b c = T3 a b c + + +main = putStr (listChar_string + (append1 (C1 '\FF' N) + (life1 (generations ()) (start ())))) + +listChar_string :: L Char -> String +listChar_string N = [] +listChar_string (C1 x xs) = x : listChar_string xs + +start :: a -> L (L Int) +start x = (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 N + (C1 + (C1 0 + (C1 0 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 1 + (C1 0 N))))))))))))))))))))))))))) N))))))))))))))) + +-- Calculating the next generation + +gen1 :: Int -> L (L Int) -> L (L Int) +gen1 n board = map1 row1 (shift1 (copy1 n 0) board) + +row1 :: Tuple3 (L Int) (L Int) (L Int) -> L Int +row1 (T3 last this next) + = zipWith31 elt1 (shift2 0 last) + (shift2 0 this) + (shift2 0 next) + + +elt1 :: Tuple3 Int Int Int + -> (Tuple3 Int Int Int) + -> (Tuple3 Int Int Int) -> Int +elt1 (T3 a b c) (T3 d e f) (T3 g h i) + = if (not (eq tot 2)) + && (not (eq tot 3)) + then 0 + else if (eq tot 3) then 1 else e + where tot = a `plus` b `plus` c `plus` d + `plus` f `plus` g `plus` h `plus` i + +eq :: Int -> Int -> Bool +eq x y = x == y + +plus :: Int -> Int -> Int +plus x y = x + y + +shiftr1 :: L Int -> L (L Int) -> L (L Int) +shiftr1 x xs = append2 (C1 x N) (init1 xs) + +shiftl1 :: L Int -> L (L Int) -> L (L Int) +shiftl1 x xs = append2 (tail1 xs) (C1 x N) + +shift1 :: L Int -> L (L Int) + -> L (Tuple3 (L Int) (L Int) (L Int)) +shift1 x xs = zip31 (shiftr1 x xs) xs (shiftl1 x xs) + +shiftr2 :: Int -> L Int -> L Int +shiftr2 x xs = append3 (C1 x N) (init2 xs) + +shiftl2 :: Int -> L Int -> L Int +shiftl2 x xs = append3 (tail2 xs) (C1 x N) + +shift2 :: Int -> L Int -> L (Tuple3 Int Int Int) +shift2 x xs = zip32 (shiftr2 x xs) xs (shiftl2 x xs) + +-- copy + +copy1 :: Int -> Int -> L Int +copy1 0 x = N +copy1 n x = C1 x (copy1 (n-1) x) + +copy2 :: Int -> L Int -> L (L Int) +copy2 0 x = N +copy2 n x = C1 x (copy2 (n-1) x) + +copy3 :: Int -> Char -> L Char +copy3 0 x = N +copy3 n x = C1 x (copy3 (n-1) x) + +-- Displaying one generation + +disp1 :: (Tuple2 (L Char) (L (L Int))) -> L Char +disp1 (T2 gen xss) + = append1 gen + (append1 (C1 '\n' (C1 '\n' N)) + (foldr_1 (glue1 (C1 '\n' N)) N + (map4 (compose2 concat1 (map2 star1)) xss))) + +star1 :: Int -> L Char +star1 i = case i of + 0 -> C1 ' ' (C1 ' ' N) + 1 -> C1 ' ' (C1 'o' N) + +glue1 :: L Char -> L Char -> L Char -> L Char +glue1 s xs ys = append1 xs (append1 s ys) + +-- Generating and displaying a sequence of generations + +life1 :: Int -> L (L Int) -> L Char +life1 n xss + = foldr_1 (glue1 (copy3 (n+2) '\VT')) N + (map5 disp1 + (zip1_ (map6 (string_ListChar.show) (ints 0)) + gens)) + where + gens = take3 (740::Int) (iterate1 (gen1 n) (initial1 n xss)) + +ints :: Int -> L Int +ints x = C1 x (ints (x+1)) + +string_ListChar :: String -> L Char +string_ListChar [] = N +string_ListChar (x:xs) = C1 x (string_ListChar xs) + +initial1 :: Int -> L (L Int) -> L (L Int) +initial1 n xss = take1 n (append2 (map3 (compose1 (take2 n) + (`append3` (copy1 n 0))) xss) + (copy2 n (copy1 n 0))) + +iterate1 :: (L (L Int) -> L (L Int)) + -> L (L Int) -> L (L (L Int)) +iterate1 f x = C1 x (iterate1 f (f x)) + +-- versions of built in functions + +-- take +take1 :: Int -> L (L Int) -> L (L Int) +take1 0 _ = N +take1 _ N = N +--should be:take1 (n+1) (C1 x xs) = C1 x (take1 n xs) +take1 n (C1 x xs) | n < 0 = error "Main.take1" + | otherwise = C1 x (take1 (n-1) xs) + +take2 :: Int -> L Int -> L Int +take2 0 _ = N +take2 _ N = N +--should be:take2 (n+1) (C1 x xs) = C1 x (take2 n xs) +take2 n (C1 x xs) | n < 0 = error "Main.take2" + | otherwise = C1 x (take2 (n-1) xs) + +take3 :: Int -> L (L (L Int)) + -> L (L (L Int)) +take3 0 _ = N +take3 _ N = N +take3 n (C1 x xs) = C1 x (take3 (n-1) xs) + +-- init + +init1 :: L (L Int) -> L (L Int) +init1 (C1 x N) = N +init1 (C1 x xs) = C1 x (init1 xs) +init1 N = error "init1 got a bad list" + +init2 :: L Int -> L Int +init2 (C1 x N) = N +init2 (C1 x xs) = C1 x (init2 xs) +init2 N = error "init1 got a bad list" + +-- tail + +tail1 :: L (L Int) -> L (L Int) +tail1 (C1 _ xs) = xs +tail1 N = error "tail1 got a bad list" + +tail2 :: L Int -> L Int +tail2 (C1 _ xs) = xs +tail2 N = error "tail2 got a bad list" + +-- maps + +map1 :: (Tuple3 (L Int) (L Int) (L Int) -> L Int) -> + L (Tuple3 (L Int) (L Int) (L Int)) + -> L (L Int) +map1 f N = N +map1 f (C1 x xs) = C1 (f x) (map1 f xs) + +map2 :: (Int -> L Char) -> L Int -> L (L Char) +map2 f N = N +map2 f (C1 x xs) = C1 (f x) (map2 f xs) + +map3 :: (L Int -> L Int) -> L (L Int) -> L (L Int) +map3 f N = N +map3 f (C1 x xs) = C1 (f x) (map3 f xs) + +map4 :: (L Int -> L Char) + -> L (L Int) -> L (L Char) +map4 f N = N +map4 f (C1 x xs) = C1 (f x) (map4 f xs) + +map5 :: (Tuple2 (L Char) (L (L Int)) -> L Char) + -> L (Tuple2 (L Char) (L (L Int))) + -> L (L Char) +map5 f N = N +map5 f (C1 x xs) = C1 (f x) (map5 f xs) + +map6 :: (Int -> L Char) -> L Int -> L (L Char) +map6 f N = N +map6 f (C1 x xs) = C1 (f x) (map6 f xs) + +-- compose + +compose2 :: (L (L Char) -> L Char) + -> (L Int -> L (L Char)) + -> L Int -> L Char +compose2 f g xs = f (g xs) + +compose1 :: (L Int -> L Int) + -> (L Int -> L Int) -> L Int -> L Int +compose1 f g xs = f (g xs) + +-- concat + +concat1 :: L (L Char) -> L Char +concat1 = foldr_1 append1 N + +-- foldr + +foldr_1 :: (L Char -> L Char -> L Char) + -> L Char -> L (L Char) -> L Char +foldr_1 f a N = a +foldr_1 f a (C1 x xs) = f x (foldr_1 f a xs) + +-- appends + +append1 :: L Char -> L Char -> L Char +append1 N ys = ys +append1 (C1 x xs) ys = C1 x (append1 xs ys) + +append2 :: L (L Int) -> L (L Int) -> L (L Int) +append2 N ys = ys +append2 (C1 x xs) ys = C1 x (append2 xs ys) + +append3 :: L Int -> L Int -> L Int +append3 N ys = ys +append3 (C1 x xs) ys = C1 x (append3 xs ys) + +-- zips + +pzip f (C1 x1 xs) (C1 y1 ys) + = C1 (f x1 y1) (pzip f xs ys) +pzip f _ _ = N + + +zip1_ :: L (L Char) + -> L (L (L Int)) + -> L (Tuple2 (L Char) (L (L Int))) +zip1_ = pzip T2 + +zip2_ :: L (L Int) + -> L (L Int) + -> L (Tuple2 (L Int) (L Int)) +zip2_ = pzip T2 + +zip3d :: L Int -> (Tuple2 (L Int) (L Int)) + -> (Tuple3 (L Int) (L Int) (L Int)) +zip3d x (T2 y z) = T3 x y z + +zip3_ :: L (L Int) + -> L (Tuple2 (L Int) (L Int)) + -> L (Tuple3 (L Int) (L Int) (L Int)) +zip3_ = pzip zip3d + +zip4_ :: L Int + -> L Int + -> L (Tuple2 Int Int) +zip4_ = pzip T2 + +zip5d :: Int -> (Tuple2 Int Int) -> (Tuple3 Int Int Int) +zip5d x (T2 y z) = T3 x y z + +zip5_ :: L Int + -> L (Tuple2 Int Int) + -> L (Tuple3 Int Int Int) +zip5_ = pzip zip5d + +zip6_ :: L (Tuple3 Int Int Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple2 (Tuple3 Int Int Int) + (Tuple3 Int Int Int)) +zip6_ = pzip T2 + +zip31 :: L (L Int) -> L (L Int) + -> L (L Int) + -> L (Tuple3 (L Int) (L Int) (L Int)) +zip31 as bs cs + = zip3_ as (zip2_ bs cs) + +zip32 :: L Int -> L Int -> L Int + -> L (Tuple3 Int Int Int) +zip32 as bs cs + = zip5_ as (zip4_ bs cs) + +-- zipWith + +zipWith21 :: ((Tuple3 Int Int Int) + -> (Tuple2 (Tuple3 Int Int Int) + (Tuple3 Int Int Int)) -> Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple2 (Tuple3 Int Int Int) + (Tuple3 Int Int Int)) + -> L Int +zipWith21 = pzip + +zipWith31 :: ((Tuple3 Int Int Int) + -> (Tuple3 Int Int Int) + -> (Tuple3 Int Int Int) -> Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple3 Int Int Int) + -> L (Tuple3 Int Int Int) -> L Int +zipWith31 z as bs cs + = zipWith21 z' as (zip6_ bs cs) + where z' a (T2 b c) = z a b c diff --git a/compiler/ilxGen/tests/reduce.ml b/compiler/ilxGen/tests/reduce.ml new file mode 100644 index 0000000000..cad379b522 --- /dev/null +++ b/compiler/ilxGen/tests/reduce.ml @@ -0,0 +1,101 @@ + + +type kind = + ARROW of kind * kind + | TYP + +type tycon = + | TyVar of int + | FUN + | LIST + | STRING + +type typ = + TyForall of kind * typ + | TyApp of tycon * typ list + +type exp = + | AbsTm of typ * exp + | Var of int + | App of exp * exp + | String of string + | AbsTy of kind * exp + | AppTy of exp * typ + +type ttyp = + | TTyFun of ttyp * ttyp + | TTyList of ttyp + | TTyString + | TTyAny + | TTyVar of int + | TTyForall of ttyp + +type texp = + | TAbsTm of ttyp * texp + | TVar of int + | TApp of texp * texp + | TString of string + | TLetTy of texp * texp + | TCast of texp * ttyp + + | TAppTy of texp * ttyp + | TAbsTy of texp + + +let (-->) x y = TyApp (FUN, [x;y]) +let (--->) x y = TTyFun (x,y) + +let rec trans_kind = function + ARROW (k1,k2) -> (trans_kind k1 ---> trans_kind k2) + | TYP -> (TTyForall TANY ---> TTyAny) + +let rec trans_typ_arg_aux = function + (* TyForall (k,ty) -> TAbsTm (trans_kind k, TAbsTy (trans_typ ty)) ??? *) + | TyApp (TyVar tv, args) -> failwith "unreduced" + | ty -> TAbsTm (trans_kind k, TAbsTy (trans_typ ty))failwith "unreduced" + | +let rec trans_typ_arg env = function + | TyApp (FUN, []) -> + TAbsTm + (trans_kind TYP, + TLetTy (TVar 0, + TAbsTm + (trans_kind TYP, + TLetTy (TVar 0, + TAbsTm + (TTyForall TANY, + TAppTy (TVar 0, TTyFun (TTyVar 0, TTyVar 1))))))) + | TyApp (TyVar tv, args) -> + try List.assoc (tv,args) env + with Not_found -> failwith "trans_typ: unreduced type variable" + | ty -> TAbsTm (TTyForall TANY, TAppTy (TVar 0, trans_typ env ty)) +(* + | TyApp (STRING, []) -> TAbsTm (TTyForall TANY, TAppTy (TVar 0, TTyString)) + | TyApp (FUN, [l;r]) -> TAbsTm (TTyForall TANY, TAppTy (TVar 0, TTyFun (trans_typ l, trans_typ r))) +*) + + +let rec trans_typ env = function + TyForall (k,ty) -> (trans_kind k ---> TTyAny) + | TyApp (TyVar tv, args) -> + try List.assoc (tv,args) env + with Not_found -> failwith "trans_typ: unreduced type variable" + | TyApp (FUN, [l;r]) -> TTyFun (trans_typ env l, trans_typ env r) + | TyApp (STRING, []) -> TTyString + | _ -> failwith "trans_typ: badly formed input type" + + +let rec trans_exp env = function + | AbsTm (ty,e) -> TAbsTm(trans_typ ty, trans_exp e) + | Var n -> TVar n + | App (l,r) -> TApp(trans_exp l, trans_exp r) + | String s -> TString s + | AbsTy (k,e) -> TAbsTm(trans_kind k, reduce env e) + | AppTy (tm,ty) -> TAppTy(trans_exp tm, trans_typ_arg env ty) + + +open Format;; + + +let rec pp_print_exp pps = function + L e -> fprintf pps "\ diff --git a/compiler/ilxGen/tests/test1-nostdlib.hs b/compiler/ilxGen/tests/test1-nostdlib.hs new file mode 100644 index 0000000000..1e9053ea41 --- /dev/null +++ b/compiler/ilxGen/tests/test1-nostdlib.hs @@ -0,0 +1,4 @@ +module Test1_nostdlib where +foreign import "ilxHello" unsafe ilxHello :: () + +ilx_main_no_stdlib = ilxHello diff --git a/compiler/ilxGen/tests/test1.hs b/compiler/ilxGen/tests/test1.hs new file mode 100644 index 0000000000..10f307e08e --- /dev/null +++ b/compiler/ilxGen/tests/test1.hs @@ -0,0 +1 @@ +main = putStr "HELLO HELLO Hello world WORLD WORLD.\n" diff --git a/compiler/ilxGen/tests/test10.hs b/compiler/ilxGen/tests/test10.hs new file mode 100644 index 0000000000..46c384d9e0 --- /dev/null +++ b/compiler/ilxGen/tests/test10.hs @@ -0,0 +1,45 @@ + +data N = Z | S N + +choose1 n1 = + case n1 of + Z -> "even\n" + S Z -> "odd\n" + S (S m) -> choose1 m +choose2 n1 n2 = + case n1 of + Z -> choose1 n2 + S Z -> "odd\n" + S (S m) -> choose2 m n2 +choose3 n1 n2 n3 = + case n1 of + Z -> choose2 n2 n3 + S Z -> "odd\n" + S (S m) -> choose3 m n2 n3 + +choose4 n1 n2 n3 n4 = + case n1 of + Z -> choose3 n2 n3 n4 + S Z -> "odd\n" + S (S m) -> choose4 m n2 n3 n4 + +choose5 n1 n2 n3 n4 n5 = + case n1 of + Z -> choose4 n2 n3 n4 n5 + S Z -> "odd\n" + S (S m) -> choose5 m n2 n3 n4 n5 + +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 + + + +main = putStr (choose5 n6 n4 n2 n2 n1) + diff --git a/compiler/ilxGen/tests/test11.hs b/compiler/ilxGen/tests/test11.hs new file mode 100644 index 0000000000..ce53f71389 --- /dev/null +++ b/compiler/ilxGen/tests/test11.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -fglasgow-exts #-} + +import PrelGHC + +class EEq a where + (===), (/==) :: a -> a -> Bool + +-- x /= y = not (x == y) +-- x == y = not (x /= y) +-- x /= y = True + (/==) x y = mynot ((===) x y) + x === y = True + +data EOrdering = ELT | EEQ | EGT + +mynot True = False +mynot False = True + +{- +class (EEq a) => EOrd a where + ecompare :: a -> a -> EOrdering + (<<), (<<=), (>>>=), (>>>):: a -> a -> Bool + emax, emin :: a -> a -> a + +-- An instance of Ord should define either compare or <= +-- Using compare can be more efficient for complex types. + ecompare x y + | x === y = EEQ + | x <<= y = ELT -- NB: must be '<=' not '<' to validate the + -- above claim about the minimal things that can + -- be defined for an instance of Ord + | otherwise = EGT + + x <<= y = case ecompare x y of { EGT -> False; _other -> True } + x << y = case ecompare x y of { ELT -> True; _other -> False } + x >>>= y = case ecompare x y of { ELT -> False; _other -> True } + x >>> y = case ecompare x y of { EGT -> True; _other -> False } + + -- These two default methods use '>' rather than compare + -- because the latter is often more expensive + emax x y = if x >>> y then x else y + emin x y = if x >>> y then y else x +-} + +data EInt = EI Int# + +ezeroInt, eoneInt, etwoInt, emaxInt, eminInt :: EInt +ezeroInt = EI 0# +eoneInt = EI 1# +etwoInt = EI 2# +eminInt = EI (-2147483648#) -- GHC <= 2.09 had this at -2147483647 +emaxInt = EI 2147483647# +eeqInt (EI x) (EI y) = x ==# y +eneInt (EI x) (EI y) = x /=# y + +instance EEq EInt where + (===) x y = x `eeqInt` y + (/==) x y = x `eneInt` y + +main = putStr (if (ezeroInt === eoneInt) then "no!\n" else "yes!\n") + diff --git a/compiler/ilxGen/tests/test12.hs b/compiler/ilxGen/tests/test12.hs new file mode 100644 index 0000000000..216c792f32 --- /dev/null +++ b/compiler/ilxGen/tests/test12.hs @@ -0,0 +1,44 @@ +class NewFunctor f where + new_fmap :: (a -> b) -> f a -> f b + +data N a = Z a | S (N a) + +nmap f (Z x) = Z (f x) +nmap f (S n) = S (nmap f n) + +tag (Z x) = x +tag (S n) = tag n + +instance NewFunctor N where + new_fmap = nmap + +--class Strange f where +-- zero :: a -> f a +-- suc :: f a -> f a +-- tag :: f a -> a + + +--class FMonad m where +-- (>>=) :: m a -> (a -> m b) -> m b +-- (>>) :: m a -> m b -> m b +-- return :: a -> m a +-- fail :: String -> m a +-- +-- m >> k = m >>= \_ -> k +-- fail s = error s + + + + +--instance Strange N +-- where +-- zero x = Z x +-- suc y = S y +-- tag n = gettag n + +twice :: NewFunctor f => (a -> a) -> f a -> f a +twice f x = new_fmap f (new_fmap f x) + +main = putStr (tag (nmap (\x -> x) (Z "hello world\n"))) +--main = putStr (tag (nmap (\x -> x) (Z "hello world\n"))) +-- main = putStr (tag {- (twice (\x -> x) -} (Z "hello world\n")) diff --git a/compiler/ilxGen/tests/test13.hs b/compiler/ilxGen/tests/test13.hs new file mode 100644 index 0000000000..559c8674fa --- /dev/null +++ b/compiler/ilxGen/tests/test13.hs @@ -0,0 +1,20 @@ +class NewFunctor f where + inj :: a -> f a + surj :: f a -> a + +data N a = Z a + +ninj x = (Z x) +nsurj (Z x) = x + +instance NewFunctor N where + inj = ninj + surj = nsurj + +twice :: NewFunctor f => a -> f (f a) +twice x = inj(inj x) + +undo :: NewFunctor f => f (f a) -> a +undo x = surj(surj x) + +main = putStr (undo (Z (Z "hello world\n"))) diff --git a/compiler/ilxGen/tests/test14.hs b/compiler/ilxGen/tests/test14.hs new file mode 100644 index 0000000000..86b5d1c821 --- /dev/null +++ b/compiler/ilxGen/tests/test14.hs @@ -0,0 +1,11 @@ +class EMonad m where + aaaaa :: m a -> (a -> m b) -> m b + bbbbb :: m a -> m b -> m b + + bbbbb m k = aaaaa m (\_ -> k) + -- = \M \A \B -> \m:(M A) -> \k:(M B) -> aaaaa M A B m (\_:A -> k: M B) + -- Free types must include "A"!!! + +main = putStr "hello world\n" + + diff --git a/compiler/ilxGen/tests/test15.hs b/compiler/ilxGen/tests/test15.hs new file mode 100644 index 0000000000..3e522d757c --- /dev/null +++ b/compiler/ilxGen/tests/test15.hs @@ -0,0 +1,18 @@ + +{-# OPTIONS -fglasgow-exts -fno-implicit-prelude #-} + + +import PrelBase +import PrelList +import PrelEnum +import PrelShow +import PrelIO + + +bbuild :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a] +{-# INLINE 2 bbuild #-} +bbuild g = g (:) [] + +main = putStr "hello world\n" + + diff --git a/compiler/ilxGen/tests/test16.hs b/compiler/ilxGen/tests/test16.hs new file mode 100644 index 0000000000..0e8b9974a9 --- /dev/null +++ b/compiler/ilxGen/tests/test16.hs @@ -0,0 +1,5 @@ + + +data MMaybe a = No | Yes a + +main = putStr "hello world\n"
\ No newline at end of file diff --git a/compiler/ilxGen/tests/test17.hs b/compiler/ilxGen/tests/test17.hs new file mode 100644 index 0000000000..5e551b2dcd --- /dev/null +++ b/compiler/ilxGen/tests/test17.hs @@ -0,0 +1,44 @@ +{-# OPTIONS -fno-implicit-prelude #-} + +module Test17 where + +import PrelGHC +import PrelBase + +data Exception = IOException IOError | OtherExc + +data IOError + = IOError + String + +tthrow :: Exception -> a + +tthrow exception = raise# exception +ccatchException (IO m) k = IO (\s -> catch# m (\ex -> unIO (k ex)) s) + + +ccatch :: IO a -> (IOError -> IO a) -> IO a +ccatch m k = ccatchException m handler + where handler (IOException err) = k err + handler other = tthrow other + +ccatchNonIO :: IO a -> (Exception -> IO a) -> IO a +ccatchNonIO m k = ccatchException m handler + where handler (IOException err) = ioError err + handler other = k other + +newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) + +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIO (IO a) = a + +ioError :: IOError -> IO a +ioError err = IO (\s -> tthrow (IOException err) s) + + + +blockAsyncExceptions :: IO a -> IO a +blockAsyncExceptions (IO io) = IO (blockAsyncExceptions# io) + +unblockAsyncExceptions :: IO a -> IO a +unblockAsyncExceptions (IO io) = IO (unblockAsyncExceptions# io) diff --git a/compiler/ilxGen/tests/test18.hs b/compiler/ilxGen/tests/test18.hs new file mode 100644 index 0000000000..12ca7413f1 --- /dev/null +++ b/compiler/ilxGen/tests/test18.hs @@ -0,0 +1,129 @@ +{-# OPTIONS -fno-implicit-prelude #-} + +module Test18 where + +import PrelGHC +import PrelBase + +eftCharFB c n x y = go x + where + go x | x ># y = n + | otherwise = C# (chr# x) `c` go (x +# 1#) + + +eftIntFB c n x y | x ># y = n + | otherwise = go x + where + go x = I# x `c` if x ==# y then n else go (x +# 1#) + +eftIntList x y | x ># y = [] + | otherwise = go x + where + go x = I# x : if x ==# y then [] else go (x +# 1#) + + +efdCharFB c n x1 x2 + | delta >=# 0# = go_up_char_fb c n x1 delta 255# + | otherwise = go_dn_char_fb c n x1 delta 0# + where + delta = x2 -# x1 + +efdCharList x1 x2 + | delta >=# 0# = go_up_char_list x1 delta 255# + | otherwise = go_dn_char_list x1 delta 0# + where + delta = x2 -# x1 + +efdtCharFB c n x1 x2 lim + | delta >=# 0# = go_up_char_fb c n x1 delta lim + | otherwise = go_dn_char_fb c n x1 delta lim + where + delta = x2 -# x1 + +efdtCharList x1 x2 lim + | delta >=# 0# = go_up_char_list x1 delta lim + | otherwise = go_dn_char_list x1 delta lim + where + delta = x2 -# x1 + +go_up_char_fb c n x delta lim + = go_up x + where + go_up x | x ># lim = n + | otherwise = C# (chr# x) `c` go_up (x +# delta) + +go_dn_char_fb c n x delta lim + = go_dn x + where + go_dn x | x <# lim = n + | otherwise = C# (chr# x) `c` go_dn (x +# delta) + +go_up_char_list x delta lim + = go_up x + where + go_up x | x ># lim = [] + | otherwise = C# (chr# x) : go_up (x +# delta) + + +go_dn_char_list x delta lim + = go_dn x + where + go_dn x | x <# lim = [] + | otherwise = C# (chr# x) : go_dn (x +# delta) + +efdtIntFB c n x1 x2 y + | delta >=# 0# = if x1 ># y then n else go_up_int_fb c n x1 delta lim + | otherwise = if x1 <# y then n else go_dn_int_fb c n x1 delta lim + where + delta = x2 -# x1 + lim = y -# delta + +efdtIntList x1 x2 y + | delta >=# 0# = if x1 ># y then [] else go_up_int_list x1 delta lim + | otherwise = if x1 <# y then [] else go_dn_int_list x1 delta lim + where + delta = x2 -# x1 + lim = y -# delta + +efdIntFB c n x1 x2 + | delta >=# 0# = go_up_int_fb c n x1 delta ( 2147483647# -# delta) + | otherwise = go_dn_int_fb c n x1 delta ((-2147483648#) -# delta) + where + delta = x2 -# x1 + +efdIntList x1 x2 + | delta >=# 0# = go_up_int_list x1 delta ( 2147483647# -# delta) + | otherwise = go_dn_int_list x1 delta ((-2147483648#) -# delta) + where + delta = x2 -# x1 + +-- In all of these, the (x +# delta) is guaranteed not to overflow + +go_up_int_fb c n x delta lim + = go_up x + where + go_up x | x ># lim = I# x `c` n + | otherwise = I# x `c` go_up (x +# delta) + +go_dn_int_fb c n x delta lim + = go_dn x + where + go_dn x | x <# lim = I# x `c` n + | otherwise = I# x `c` go_dn (x +# delta) + +go_up_int_list x delta lim + = go_up x + where + go_up x | x ># lim = [I# x] + | otherwise = I# x : go_up (x +# delta) + +go_dn_int_list x delta lim + = go_dn x + where + go_dn x | x <# lim = [I# x] + | otherwise = I# x : go_dn (x +# delta) +eftInt = eftIntList +efdInt = efdIntList +efdtInt = efdtIntList + + diff --git a/compiler/ilxGen/tests/test19.hs b/compiler/ilxGen/tests/test19.hs new file mode 100644 index 0000000000..a292599031 --- /dev/null +++ b/compiler/ilxGen/tests/test19.hs @@ -0,0 +1,37 @@ + +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} + + +module Test19 where + +import PrelST +import PrelBase +import PrelErr + +newtype IIO a = IIO (State# RealWorld -> (# State# RealWorld, a #)) + +unIIO :: IIO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIIO (IIO a) = a + +instance Functor IIO where + fmap f x = x >>= (return . f) + +instance Monad IIO where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + m >> k = m >>= \ _ -> k + return x = returnIIO x + + m >>= k = bindIIO m k + fail s = error s -- not ioError? + + +bindIIO :: IIO a -> (a -> IIO b) -> IIO b +bindIIO (IIO m) k = IIO ( \ s -> + case m s of + (# new_s, a #) -> unIIO (k a) new_s + ) + +returnIIO :: a -> IIO a +returnIIO x = IIO (\ s -> (# s, x #)) diff --git a/compiler/ilxGen/tests/test1b.hs b/compiler/ilxGen/tests/test1b.hs new file mode 100644 index 0000000000..c4b2336df1 --- /dev/null +++ b/compiler/ilxGen/tests/test1b.hs @@ -0,0 +1,104 @@ +-- To start: +-- source /bin/devghc + +-- To compile GHC +-- make ilxGen/IlxGen.o hsc + +-- To compile ILXASM +-- (cd /devel/fcom/src; make bin/ilxasm.exe) + +-- To compile to ILX +-- (cd ilxGen/tests; ../../../driver/ghc-inplace --ilx test.hs) + + + +-- To generate a complete ILX file, including preludes for GHC and ILX: +-- (cd ilxGen/tests/; cat prelude.ilx test.ilx /devel/fcom/src/ilxasm/stdlib-func.ilx > test.full.ilx) + +-- Run ILXASM to get a IL +-- ( cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm --no-stdlib test.full.ilx > test.il) + +-- To compile IL to .EXE or .DLL: +-- With build of VS (e.g. Don & Andrew) +-- ( cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && ilasm test.il") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- ( cd ilxGen/tests/; ilasm test.il) + +-- To validate .EXE: +-- (cd /devel/fcom/src; make bin/ilvalid.exe mscorlib.vlb) +-- (export ILVALID_HOME=/devel/fcom/src; cd ilxGen/tests/; /devel/fcom/src/bin/ilvalid.exe test.il) + +-- To run unverifiable code: +-- With build of VS (e.g. Don & Andrew) +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.exe") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- (cd ilxGen/tests/; ./test.exe) + +-- To compile ILX to verifiable code and verify +-- (cd /devel/fcom/src; make bin/ilxasm.exe bin/ilverify.exe) && (cd ilxGen/tests/; export ILVALID_HOME=/devel/fcom/src; cat prelude.ilx test.ilx /devel/fcom/src/assem/stdlib-func.ilx > test.full.ilx && cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm test.full.ilx > test.safe.il && /devel/fcom/src/bin/ilverify.exe test.safe.il) + +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.safe.exe") + +--append:: [Char] -> [Char] -> [Char] +--append [] l2 = l2 +--append (h:t) l2 = h:append t l2 + +data N = Z | S N + +chooseN n = + case n of + Z -> "even\n" + S Z -> "odd\n" + S (S m) -> chooseN m + +signN n = + case n of + Z -> Z + S Z -> S Z + S (S m) -> signN m +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +mul n m = + case n of + Z -> Z + S nn -> add m (mul nn m) + +pow n m = + case m of + Z -> S Z + S mm -> mul n (pow n mm) + +sq n = mul n n + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 +n8 = add n2 n6 +n10 = add n2 n8 +n11 = add n1 n10 +n12 = add n1 n11 +n13 = add n1 n12 +n14 = add n1 n13 +n15 = add n1 n14 +n16 = add n1 n15 +n17 = add n1 n16 +n18 = add n1 n17 +n19 = add n1 n18 +n20 = add n1 n18 + +bign = pow n2 n19 +bign1 = add bign n1 + +foldn f n acc = + case n of + Z -> acc + S x -> foldn f x (f n acc) + +main = putStr (chooseN (foldn (\x y -> add (signN x) y) (pow n2 n4) n1)) + + + diff --git a/compiler/ilxGen/tests/test2.hs b/compiler/ilxGen/tests/test2.hs new file mode 100644 index 0000000000..8b1f5b5eb6 --- /dev/null +++ b/compiler/ilxGen/tests/test2.hs @@ -0,0 +1,88 @@ +-- To start: +-- source /bin/devghc + +-- To compile GHC +-- make ilxGen/IlxGen.o hsc + +-- To compile ILXASM +-- (cd /devel/fcom/src; make bin/ilxasm.exe) + +-- To compile to ILX +-- (cd ilxGen/tests; ../../../driver/ghc-inplace --ilx test.hs) + + + +-- To generate a complete ILX file, including preludes for GHC and ILX: +-- (cd ilxGen/tests/; cat prelude.ilx test.ilx /devel/fcom/src/ilxasm/stdlib-func.ilx > test.full.ilx) + +-- Run ILXASM to get a IL +-- ( cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm --no-stdlib test.full.ilx > test.il) + +-- To compile IL to .EXE or .DLL: +-- With build of VS (e.g. Don & Andrew) +-- ( cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && ilasm test.il") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- ( cd ilxGen/tests/; ilasm test.il) + +-- To validate .EXE: +-- (cd /devel/fcom/src; make bin/ilvalid.exe mscorlib.vlb) +-- (export ILVALID_HOME=/devel/fcom/src; cd ilxGen/tests/; /devel/fcom/src/bin/ilvalid.exe test.il) + +-- To run unverifiable code: +-- With build of VS (e.g. Don & Andrew) +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.exe") +-- With Lightning SDK, where env. variables are on path (e.g. Reuben): +-- (cd ilxGen/tests/; ./test.exe) + +-- To compile ILX to verifiable code and verify +-- (cd /devel/fcom/src; make bin/ilxasm.exe bin/ilverify.exe) && (cd ilxGen/tests/; export ILVALID_HOME=/devel/fcom/src; cat prelude.ilx test.ilx /devel/fcom/src/assem/stdlib-func.ilx > test.full.ilx && cd ilxGen/tests/; /devel/fcom/src/bin/ilxasm.exe --no-ilasm test.full.ilx > test.safe.il && /devel/fcom/src/bin/ilverify.exe test.safe.il) + +-- (cd ilxGen/tests/; cmd /C "c:\\bin\\devvs.bat && .\test.safe.exe") + +--append:: [Char] -> [Char] -> [Char] +--append [] l2 = l2 +--append (h:t) l2 = h:append t l2 + +data N = Z | S N + +chooseN n = + case n of + Z -> "even\n" + S Z -> "odd\n" + S (S m) -> chooseN m + +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +mul n m = + case n of + Z -> Z + S nn -> add m (mul nn m) + +pow n m = + case m of + Z -> S Z + S mm -> mul n (pow n mm) + +sq n = mul n n + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 +n8 = add n2 n6 +n10 = add n2 n8 +n16 = add n6 n10 +n17 = add n1 n16 +n18 = add n8 n10 +n19 = add n1 n18 +n20 = add n4 n16 + +bign = pow n2 n10 +bign1 = add bign n1 + +main = putStr (chooseN bign1) + + diff --git a/compiler/ilxGen/tests/test20.hs b/compiler/ilxGen/tests/test20.hs new file mode 100644 index 0000000000..157a16da1d --- /dev/null +++ b/compiler/ilxGen/tests/test20.hs @@ -0,0 +1,9 @@ + +data N = Z | S N + +res Z x y = (# x, y #) +res (S n) x y = res n x y + +(# x, y #) = res (S Z) "no!" "hello world\n" + +main = putStr y diff --git a/compiler/ilxGen/tests/test21.hs b/compiler/ilxGen/tests/test21.hs new file mode 100644 index 0000000000..1870f22b97 --- /dev/null +++ b/compiler/ilxGen/tests/test21.hs @@ -0,0 +1,13 @@ +{-# OPTIONS -fno-implicit-prelude #-} + +import PrelIOBase +import PrelIO +import PrelBase +import PrelAddr + +foreign import "libHS_cbits" "getErrStr__" unsafe ggetErrStr__ :: Int -> IO Addr + +main = putStr (uunsafePerformIO (ggetErrStr__ 4)) + +uunsafePerformIO :: IO Addr -> [Char] +uunsafePerformIO (IO m) = case m realWorld# of (# _, (A# r) #) -> (unpackCString# r) diff --git a/compiler/ilxGen/tests/test2b.hs b/compiler/ilxGen/tests/test2b.hs new file mode 100644 index 0000000000..08a391f799 --- /dev/null +++ b/compiler/ilxGen/tests/test2b.hs @@ -0,0 +1,2 @@ +foreign import "ilxHello" unsafe ilxHello :: IO () +main = ilxHello diff --git a/compiler/ilxGen/tests/test2c.hs b/compiler/ilxGen/tests/test2c.hs new file mode 100644 index 0000000000..d01df051f8 --- /dev/null +++ b/compiler/ilxGen/tests/test2c.hs @@ -0,0 +1,14 @@ +import PrelIOBase + + +bindIO2 :: IO () -> IO () -> IO () +bindIO2 m (IO k) = IO ( \ s -> k s ) + +foreign import "ilxHello" unsafe ilxHello :: IO () + +data N = S N | Z + +f Z = bindIO2 +f (S x) = f x + +main = f(S Z) ilxHello ilxHello diff --git a/compiler/ilxGen/tests/test2d.hs b/compiler/ilxGen/tests/test2d.hs new file mode 100644 index 0000000000..8126127a32 --- /dev/null +++ b/compiler/ilxGen/tests/test2d.hs @@ -0,0 +1,7 @@ +foreign import ccall "libHS_cbits.so" "get_prog_argc" unsafe primArgc :: Int + +foreign import "ilxHello" unsafe ilxHello :: IO () +foreign import "ilxBad" unsafe ilxBad :: IO () + + +main = if (primArgc == 0) then ilxHello else ilxBad diff --git a/compiler/ilxGen/tests/test3.hs b/compiler/ilxGen/tests/test3.hs new file mode 100644 index 0000000000..0254ee41c4 --- /dev/null +++ b/compiler/ilxGen/tests/test3.hs @@ -0,0 +1,24 @@ +foreign import "ilxHello" unsafe ilxHello :: IO () +foreign import "ilxBad" unsafe ilxBad :: IO () + +class Eqq a where + eqq :: a -> Bool + eqq2 :: a -> Bool + +-- x /= y = not (x == y) +-- x == y = not (x /= y) +-- x /= y = True + eqq x = False + eqq2 x = True + + +data Unit = Unit + +instance Eqq Unit +-- where +-- eqq Unit = True +-- eqq2 Unit = False + +choose x = if eqq x then ilxHello else if eqq2 x then ilxBad else ilxBad + +main = choose Unit diff --git a/compiler/ilxGen/tests/test4.hs b/compiler/ilxGen/tests/test4.hs new file mode 100644 index 0000000000..080c6521e3 --- /dev/null +++ b/compiler/ilxGen/tests/test4.hs @@ -0,0 +1,47 @@ +class Eqq a where + evenN :: a -> Bool + oddN :: a -> Bool + evenN x = False + oddN x = True + + +data N = Z | S N + +instance Eqq N + where + evenN Z = True + evenN (S x) = oddN x + oddN Z = False + oddN (S x) = evenN x + +choose x = if evenN x then "hello world (evenN)\n" else if oddN x then "hello world (oddN)\n" else "no!\n" + +add n m = + case n of + Z -> m + S nn -> S (add nn m) + +mul n m = + case n of + Z -> Z + S nn -> add m (mul nn m) + +pow n m = + case m of + Z -> S Z + S mm -> mul n (pow n mm) + +n1 = S Z +n2 = add n1 n1 +n4 = add n2 n2 +n6 = add n2 n4 +n8 = add n2 n6 +n10 = add n2 n8 +n16 = add n6 n10 +n18 = add n8 n10 +n20 = add n4 n16 + +bign = pow n2 n16 +bign1 = add bign n1 + +main = putStr (choose bign1) diff --git a/compiler/ilxGen/tests/test5.hs b/compiler/ilxGen/tests/test5.hs new file mode 100644 index 0000000000..13d6028c02 --- /dev/null +++ b/compiler/ilxGen/tests/test5.hs @@ -0,0 +1,5 @@ +data One a = One a + +choose (One x) = x +main = putStr (choose (One "hello world\n")) + diff --git a/compiler/ilxGen/tests/test6.hs b/compiler/ilxGen/tests/test6.hs new file mode 100644 index 0000000000..17e51ab51d --- /dev/null +++ b/compiler/ilxGen/tests/test6.hs @@ -0,0 +1,8 @@ +data List a = Cons a (List a) + +hdL (Cons x y) = x +tlL (Cons x y) = y + +test = Cons "hello world\n" test +main = putStr (hdL (tlL test)) + diff --git a/compiler/ilxGen/tests/test7.hs b/compiler/ilxGen/tests/test7.hs new file mode 100644 index 0000000000..c146038052 --- /dev/null +++ b/compiler/ilxGen/tests/test7.hs @@ -0,0 +1,8 @@ +data List a = Cons a (List a) + +hdL (Cons x y) = x +tlL (Cons x y) = y + +mk f x = f x (mk f x) +main = putStr (hdL (tlL (mk Cons "hello world!\n"))) + diff --git a/compiler/ilxGen/tests/test8.hs b/compiler/ilxGen/tests/test8.hs new file mode 100644 index 0000000000..94a7e1f83d --- /dev/null +++ b/compiler/ilxGen/tests/test8.hs @@ -0,0 +1,8 @@ +data Inf a = A (Inf a) + +hd (A x) = x + +choose (A (A x)) = "hello world\n" +mk f = f (mk f) +main = putStr (choose (hd (mk A))) + diff --git a/compiler/ilxGen/tests/test9.hs b/compiler/ilxGen/tests/test9.hs new file mode 100644 index 0000000000..311b65c4e1 --- /dev/null +++ b/compiler/ilxGen/tests/test9.hs @@ -0,0 +1,10 @@ +data Tree a = Node (Tree a) (Tree a) + +left (Node x y) = x +right (Node x y) = y + +choose (Node (Node _ _) (Node _ _)) = "hello world!\n" + +mk f = f (mk f) (mk f) +main = putStr (choose (mk Node)) + diff --git a/compiler/ilxGen/tests/yes.hs b/compiler/ilxGen/tests/yes.hs new file mode 100644 index 0000000000..1dc4f085fd --- /dev/null +++ b/compiler/ilxGen/tests/yes.hs @@ -0,0 +1,5 @@ + +foreign import "ilxHello" unsafe ilxHello :: IO () + +main :: IO () +main = ilxHello >> main
\ No newline at end of file diff --git a/compiler/ilxGen/tests/yes2.hs b/compiler/ilxGen/tests/yes2.hs new file mode 100644 index 0000000000..7fa20c5b7d --- /dev/null +++ b/compiler/ilxGen/tests/yes2.hs @@ -0,0 +1,18 @@ + +import PrelIOBase +foreign import "ilxHello" unsafe ilxHello :: IO () + + + +seqIO :: IO () -> IO () -> IO () +seqIO (IO m) (IO k) = IO ( \ s -> + case m s of + (# new_s, a #) -> k new_s + ) + + +yes () = seqIO ilxHello (yes ()) + +main :: IO () +main = yes () + |