Commit a1d221a2 authored by dnt's avatar dnt

[project @ 1996-11-26 15:44:35 by dnt]

Merged in changes from new-build-system branch
parent c29bb749
{-
From: Paul Sanders <psanders@srd.bt.co.uk>
To: partain
Subject: A puzzle for you
Date: Mon, 28 Oct 91 17:02:19 GMT
I'm struggling with the following code fragment at the moment:
-}
conv_list :: [a] -> [b] -> [[c]] -> Array (a,b) c -> Array (a,b) c
conv_list [] _ _ ar = ar
conv_list _ _ [] ar = ar
conv_list (r:rs) cls (rt:rts) ar
= conv_list rs cls rts ar'
where ar' = conv_elems r cls rt ar
conv_elems :: a -> [b] -> [c] -> Array (a,b) c -> Array (a,b) c
conv_elems row [] _ ar = ar
conv_elems _ _ [] ar = ar
conv_elems row (col:cls) (rt:rts) ar
= conv_elems row cls rts ar'
where ar' = ar // ((row,col) := rt)
ar_list = [[1,2,3],
[6,7,8],
[10,12,15]]
ar :: Array (Int, Int) Int
ar = conv_list [1..3] [1..3] ar_list init_ar
where init_ar = array ((1,1),(3,3)) []
main = appendChan stdout (show ar) abort done
{-
What it tries to do is turn a list of lists into a 2-d array in an incremental
fashion using 2 nested for-loops. It compiles okay on the prototype compiler
but gives a segmentation fault when it executes. I know I can define in the
array in one go (and I have done) but, for my piece of mind, I want to get this
way working properly.
Is it a bug in the prototype or is there a glaringly obvious error in my code
which I've been stupid to spot ????
Hoping its the latter,
Paul.
-}
import GlasgowIOMonad
import GlasgowIO
data CList = CNil | CCons Int CList
mk :: Int -> CList
mk n = if (n == 0) then
CNil
else
CCons 1 (mk (n - 1))
clen :: CList -> Int
clen CNil = 0
clen (CCons _ cl) = 1 + (clen cl)
main = case (clen list4) of
len4 ->
case (len4 `plusInt` len4) of
8 -> finish 65# -- 'A'
_ -> finish 66# -- 'B'
where
list4 = mk 4
finish :: IntPrim -> IO ()
finish n = ccall putchar n `thenIOPrim_` returnIO ()
import GlasgowIOMonad
import GlasgowIO
main = if foo == (1::Int) then
finish 65# -- 'A'
else
finish 66# -- 'B'
where
foo = f (f 3)
f = if ((3::Int) > (4::Int)) then inc else dec
inc, dec :: Int -> Int
inc x = x+1
dec x = x-1
finish :: IntPrim -> IO ()
finish n = ccall putchar n `thenIOPrim_` returnIO ()
import GlasgowIOMonad
import GlasgowIO
main = if foo == (16::Int) then
finish 65# -- 'A'
else
finish 66# -- 'B'
where
foo = twice twice twice inc 0
twice f x = f (f x)
inc :: Int -> Int
inc x = x+1
finish :: IntPrim -> IO ()
finish n = ccall putchar n `thenIOPrim_` returnIO ()
#define IHaveSubdirs
#if IncludeRealNoFibTests == YES
#define _RealTests real
#else
#define _RealTests /*none*/
#endif
#if IncludeSpectralNoFibTests == YES
#define _SpectralTests spectral
#else
#define _SpectralTests /*none*/
#endif
#if IncludeImaginaryNoFibTests == YES
#define _ImaginaryTests imaginary
#else
#define _ImaginaryTests /*none*/
#endif
#if IncludePENDINGNoFibTests == YES
#define _PENDINGTests PENDING
#else
#define _PENDINGTests /*none*/
#endif
#if IncludeUNUSEDNoFibTests == YES
#define _UNUSEDTests UNUSED
#else
#define _UNUSEDTests /*none*/
#endif
#if IncludeGHC_ONLYNoFibTests == YES
#define _GHC_ONLYTests GHC_ONLY
#else
#define _GHC_ONLYTests /*none*/
#endif
#if IncludePRIVATENoFibTests == YES
#define _PRIVATETests PRIVATE
#else
#define _PRIVATETests /*none*/
#endif
#if IncludeParallelNoFibTests == YES
#define _ParallelTests parallel
#else
#define _ParallelTests /*none*/
#endif
SUBDIRS = _GHC_ONLYTests _PRIVATETests _ParallelTests _PENDINGTests _UNUSEDTests _ImaginaryTests _SpectralTests _RealTests
# $Id: Makefile,v 1.2 1996/11/26 15:44:36 dnt Exp $
TOP = ..
SUBDIRS =
ifeq ($(IncludeImaginaryNoFibTests), YES)
SUBDIRS += imaginary
endif
ifeq ($(IncludeSpectralNoFibTests), YES)
SUBDIRS += spectral
endif
ifeq ($(IncludeRealNoFibTests), YES)
SUBDIRS += real
endif
ifeq ($(IncludePENDINGNoFibTests), YES)
SUBDIRS += PENDING
endif
ifeq ($(IncludeUNUSEDNoFibTests), YES)
SUBDIRS += UNUSED
endif
ifeq ($(IncludeGHC_ONLYNoFibTests), YES)
SUBDIRS += GHC_ONLY
endif
ifeq ($(IncludePRIVATENoFibTests), YES)
SUBDIRS += PRIVATE
endif
ifeq ($(IncludeParallelNoFibTests), YES)
SUBDIRS += parallel
endif
include $(TOP)/nofib/mk/nofib.mk
succ :: Int -> Int
succ x = x + 1
isdivs :: Int -> Int -> Bool
isdivs n x = mod x n /= 0
the_filter :: [Int] -> [Int]
the_filter (n:ns) = filter (isdivs n) ns
main = let
primes :: [Int]
primes = map head (iterate the_filter (iterate succ 2))
in
print (primes !! 1500)
--OLD: main = print (take 300 primes)
include $(TOP)/nofib/mk/site.mk
#-----------------------------------------------------------------------------
# General utilities
SHELL = /bin/sh
RM = rm -f
TIME = time
STRIP = strip
SIZE = size
#-----------------------------------------------------------------------------
# Haskell utilities
ifdef UseInstalledUtils
RUNSTDTEST = runstdtest
else
RUNSTDTEST = $(TOP)/glafp-utils/runstdtest/runstdtest
endif
#-----------------------------------------------------------------------------
# The 'all' target prints out the corrent configuration and builds runtests.
all ::
@echo HC = $(HC)
@echo HCFLAGS = $(HCFLAGS)
@echo RUNTESTFLAGS = $(RUNTESTFLAGS)
print_% ::
@echo HCFLAGS_$* = $(HCFLAGS_$*)
all :: $(foreach way,$(WAYS),print_$(way)) runtests
#-----------------------------------------------------------------------------
# Subdirs stuff.
ifdef SUBDIRS
clean::
@case '${MFLAGS}' in *[ik]*) set +e;; esac; \
for i in $(SUBDIRS) ; do \
$(MAKE) -C $$i $(MFLAGS) clean; \
done
veryclean::
@case '${MFLAGS}' in *[ik]*) set +e;; esac; \
for i in $(SUBDIRS) ; do \
$(MAKE) -C $$i $(MFLAGS) veryclean; \
done
runtests::
@case '${MFLAGS}' in *[ik]*) set +e;; esac; \
for i in $(SUBDIRS) ; do \
$(MAKE) -C $$i $(MFLAGS) runtests; \
done
endif
#-----------------------------------------------------------------------------
# Cleaning things.
clean ::
$(RM) *.CKP *.ln *.BAK *.bak *.o core a.out ,* *.a .emacs_* *.hi
$(RM) tags TAGS *.ind *.ilg *.idx *.idx-prev *.aux *.aux-prev *.dvi
$(RM) *.log *.toc *.lot *.lof *.blg *.info *.itxi *.itex *.cb errs
veryclean ::
$(RM) .??*~ *~ *.orig *.rej
#-----------------------------------------------------------------------------
# Nofib program targets.
ifdef PROG
ifndef SRCS
SRCS = Main.hs
endif
OBJS = $(patsubst %.lhs, %.o, $(patsubst %.hs, %.o, $(SRCS)))
define COMPILE
@echo === compiling $(PROG)/$@ $(EXTRA_HCFLAGS) ===
@$(TIME) $(HC) $(HCFLAGS) $(EXTRA_HCFLAGS) -o $@ -c $< \
$(HCFLAGS_$(patsubst .%,%,$(suffix $(basename $@))))
@echo === size of $(PROG)/$@ ===
@$(SIZE) $@
endef
%.normal.o %.mc.o %.mr.o %.mt.o %.mp.o %.mg.o %.2s.o %.1s.o %.du.o \
%.a.o %.b.o %.c.o %.d.o %.e.o %.f.o %.g.o %.h.o %.i.o %.j.o %.k.o \
%.l.o %.m.o %.n.o %.o.o %.p.o %.A.o %.B.o : %.hs
$(COMPILE)
%.normal.o %.mc.o %.mr.o %.mt.o %.mp.o %.mg.o %.2s.o %.1s.o %.du.o \
%.a.o %.b.o %.c.o %.d.o %.e.o %.f.o %.g.o %.h.o %.i.o %.j.o %.k.o \
%.l.o %.m.o %.n.o %.o.o %.p.o %.A.o %.B.o : %.lhs
$(COMPILE)
$(PROG)_% : $(OBJS:.o=.%.o)
@echo === linking $@ $(EXTRA_HCFLAGS) ===
@$(TIME) $(HC) $(HCFLAGS) $(EXTRA_HCFLAGS) -o $@ $^ $(LIBS)
@$(STRIP) $@
@echo === size of $@ ===
@$(SIZE) $@
runtest_% : $(PROG)_%
@echo === running $< $(EXTRA_RUNTESTFLAGS) ===
@$(TIME) $(RUNSTDTEST) ./$< \
$(addprefix -i ,$(wildcard $(PROG).stdin)) \
$(addprefix -o1 ,$(wildcard $(PROG).stdout)) \
$(addprefix -o2 ,$(wildcard $(PROG).stderr)) \
$(RUNTESTFLAGS) $(EXTRA_RUNTESTFLAGS)
runtests :: $(foreach way,$(WAYS),$(PROG)_$(way) runtest_$(way))
clean ::
$(RM) $(foreach way,$(WAYS),$(PROG)_$(way))
endif
#-----------------------------------------------------------------------------
# $Id: site.mk,v 1.2 1996/11/26 15:44:59 dnt Exp $
#-----------------------------------------------------------------------------
# Haskell compiler
#HC = $(TOP)/ghc/driver/ghc
HC = ghc-2.01
HCFLAGS = -H32m -K2m
#-----------------------------------------------------------------------------
# Flags to use when we run a test
RUNTESTFLAGS = +RTS -H48m -K32m --RTS
#-----------------------------------------------------------------------------
# Set WAYS according to which ways you want to build the nofib suite
WAYS = normal
#WAYS = normal mc mr mt mp mg 2s 1s du p t a b c d e f g h i j k l m n o p A B
# ================================================================
# BUILDS stuff: main sequential ones
HCFLAGS_normal =
HCFLAGS_p = -prof
HCFLAGS_t =
HCFLAGS_u =
# === builds: concurrent and parallel ============================
HCFLAGS_mc =
HCFLAGS_mr =
HCFLAGS_mt =
HCFLAGS_mp =
HCFLAGS_mg =
# === builds: non-std garbage collectors ==========================
HCFLAGS_2s = -gc-2s
HCFLAGS_1s = -gc-1s
HCFLAGS_du = -gc-du
# === builds: "user ways" =======================================
HCFLAGS_a =
HCFLAGS_b =
HCFLAGS_c =
HCFLAGS_d =
HCFLAGS_e =
HCFLAGS_f =
HCFLAGS_g =
HCFLAGS_h =
HCFLAGS_i =
HCFLAGS_j =
HCFLAGS_k =
HCFLAGS_l =
HCFLAGS_m =
HCFLAGS_n =
HCFLAGS_o =
HCFLAGS_A =
HCFLAGS_B =
TOP = ../..
SUBDIRS = anna bspt compress compress2 ebnf2ps fluid fulsom gamteb gg \
grep hidden HMMS hpg infer lift maillist mkhprog parser pic prolog \
reptile rsa symalg veritas
include $(TOP)/nofib/mk/nofib.mk
......@@ -149,29 +149,6 @@ maStrictAn table flagsInit fileName
fullEnvAug = fullEnv ++ map2nd deScheme maBaseTypes
deScheme (Scheme _ texpr) = texpr
{-
--==========================================================--
--
anna :: [Flag] -> String -> Dialogue
anna flags name
= getEnv "ANNADIR" noANNADIR (\anna_dir ->
readFile (anna_dir++"/anna_table") noTable (\tablestr ->
let table = rtReadTable tablestr in
readFile (name++".cor") noFile (\str ->
let result = maStrictAn table flags str in
appendChan stdout result writeFails done)))
where
noANNADIR err = abandon "ANNADIR not defined"
noTable err = abandon "Cannot find $ANNADIR/table"
noFile err = abandon ("Can't open "++name++".cor")
writeFails (WriteError s) = abandon s
abandon s = appendChan stdout s abort done
getEnv envvar fail succ = succ "/home/r62/users/sewardj/Bin"
twords n = "\nRead " ++ show n ++ " lattice sizes.\n"
-}
--==========================================================--
--
--main :: [Response] -> [Request]
......@@ -182,47 +159,11 @@ main = do
raw_args <- getArgs
let cmd_line_args = maGetFlags raw_args
anna_dir <- getEnv "ANNADIR"
tableStr <- readFile (anna_dir++"/anna_table")
tableStr <- readFile (anna_dir ++ "/anna_table")
file_contents <- getContents
let table = rtReadTable tableStr
putStr (maStrictAn table cmd_line_args file_contents)
{- OLD 1.2
main resps
= [
GetArgs,
fr 0 (GetEnv "ANNADIR"),
fr 1 (ReadFile ),
fr 2 (ReadChan stdin),
fr 3 (AppendChan stdout )
] ++ fr 4 [] (maStrictAn table cmd_line_args file_contents)
where
cmd_line_args = case (resps ## 0) of
StrList ss -> maGetFlags ss
_ -> panic "GetArgs request failed"
anna_dir = case (mySeq cmd_line_args (resps ## 1)) of
Str s -> s
_ -> myFail "Environment variable \"ANNADIR\" is not set."
tableStr = case (mySeq anna_dir (resps ## 2)) of
Str s -> s
_ -> myFail ("Can't read " ++ anna_dir ++ "/anna_table")
file_contents = case (mySeq (head tableStr) (resps ## 3)) of
Str s -> s
_ -> panic "ReadChan request failed"
--append_res = case (mySeq (head file_contents) (resps ## 4)) of
-- Success -> (42 :: Int)
-- _ -> panic "AppendChan request failed"
fr n x = case resps ## n of
Success -> x
_ -> x
table = rtReadTable tableStr
-}
--==========================================================--
--
......
TOP = ../../..
PROG = anna
SRCS = BaseDefs.hs MyUtils.hs Utils.hs AbstractVals2.hs \
SuccsAndPreds2.hs AbstractMisc.hs Dependancy.hs \
MakeDomains.hs Parser2.hs PrettyPrint.hs LambdaLift5.hs \
TypeCheck5.hs EtaAbstract.hs DomainExpr.hs AbsConc3.hs Apply.hs \
Inverse.hs BarakiMeet.hs BarakiConc3.hs \
Constructors.hs TExpr2DExpr.hs AbstractEval2.hs \
PrintResults.hs Simplify.hs SmallerLattice.hs \
FrontierMisc2.hs FrontierDATAFN2.hs FrontierGENERIC2.hs \
StrictAn6.hs ReadTable.hs Main.hs
EXTRA_RUNTESTFLAGS = \
-prescript ./anna.prescript -postscript ./anna.postscript \
-i big.cor -o1 big.sum.out
include $(TOP)/nofib/mk/nofib.mk
TOP = ../../..
PROG = bspt
SRCS = BSPT.lhs Euclid.lhs EuclidGMS.lhs GeomNum.lhs Init.lhs \
Input.lhs Interface.lhs Interpret.lhs Libfuns.lhs MGRlib.lhs \
Main.lhs Merge.lhs Params.lhs Prog.lhs Rationals.lhs \
Render.lhs Stdlib.lhs
include $(TOP)/nofib/mk/nofib.mk
interface Fulsom where {
{-# IMPORTING Shapes, Quad, Raster, Oct, Interval, Types #-}
main :: Dialogue {-# ARITY main = 1 #-}{-# STRICTNESS main = "T,T" ST #-}
}
This diff is collapsed.
-- Main3.hs
-- LML original: Sandra Foubister, 1990
-- Haskell translation: Colin Runciman, May 1991
-- with (map (AppendChan stdout) toMgr) *and* setup
module Main(main) where
import Mgrfuns
import Progfuns
import Auxprogfuns
import Layout
import Tilefuns
main :: [Response] -> [Request]
main ~(Str fromMgr : _) =
(ReadChan stdin: map (AppendChan stdout) toMgr)
where
toMgr = [set, potatotile ([],1,initalist) (lines fromMgr),clearup]
set :: [Char]
set = setmode 7 ++
shapewindow [0,0,1150,900] ++
setup
clearup :: [Char]
clearup = shapewindow [0,0,500,500] ++
font 8 ++
textreset ++
clear ++
font 15
module Main (main) -- fft
where {
--partain: import Fast2haskell;
#include "../Fast2haskell2.hs"
strict_show_i::Int -> [Char];
strict_show_i x=miraseq x (show x);
strict_show_d::Double -> [Char];
strict_show_d x=miraseq x (show x);
f_my_cmp a_x a_y=
if (((==) :: (Int -> Int -> Bool)) (fromEnum (f_cmp a_x a_y)) (fromEnum 't'))
then "t"
else
((++) "f(" ((++) (f_showcomplex a_x) ((++) "-" ((++) (f_showcomplex a_y)
((++) "=" ((++) (f_showcomplex (((-) :: (Complex_type -> Complex_type -> Complex_type)) a_x a_y)) ")\n"))))));
f_benchmark_main a_n=
let {
r_x=f_large a_n (64 :: Int)
} in (++) (f_sumcode (f_concat (f_map2 f_my_cmp (f_iaamain r_x) (f_rllmain r_x)))) "\n";
f_sumcode::[Char] -> [Char];
f_sumcode a_xs=
let {
f_sumcode' [] a_sum a_n=(++) (strict_show_i (((+) :: (Int -> Int -> Int)) a_sum a_n)) ((:) '/' (strict_show_i a_n));
f_sumcode' (a_x:a_xs) a_sum a_n=f_sumcode' a_xs (((+) :: (Int -> Int -> Int)) a_sum (fromEnum a_x)) (((+) :: (Int -> Int -> Int)) a_n (1 :: Int))
} in f_sumcode' a_xs (0 :: Int) (0 :: Int);
type
T_complex_array=Array_type Complex_type;
f_iaafft::Int -> Int -> T_complex_array -> T_complex_array;
f_iaafft a_size 0 a_xs=a_xs;
f_iaafft a_size a_n a_xs=
let {
r_m=f_log2 (((quot) :: (Int -> Int -> Int)) a_size (((*) :: (Int -> Int -> Int)) a_n (2 :: Int)));
r_xs'=array (bounds a_xs) (f_concat [f_mkpair a_j|a_j<-[(0 :: Int)..((-) :: (Int -> Int -> Int)) a_size (1 :: Int)],
((==) :: (Int -> Int -> Bool)) (land_i a_j (lshift_i (1 :: Int) r_m)) (0 :: Int)]);
f_mkpair a_j=
let {
r_x=(!) a_xs a_j;
r_y=(!) a_xs r_k;
r_z=((*) :: (Complex_type -> Complex_type -> Complex_type)) (f_unitroot a_size (((*) :: (Int -> Int -> Int)) a_n a_j)) r_y;
r_k=((+) :: (Int -> Int -> Int)) a_j (f_pow2 r_m)
} in (:) ((:=) a_j (((+) :: (Complex_type -> Complex_type -> Complex_type)) r_x r_z)) ((:) ((:=) r_k (((-) :: (Complex_type -> Complex_type -> Complex_type)) r_x r_z)) [])
} in f_iaafft a_size (((quot) :: (Int -> Int -> Int)) a_n (2 :: Int)) r_xs';
f_rllfft::Int -> Int -> [Complex_type] -> [Complex_type];
f_rllfft a_size a_n (a_x:[])=(:) a_x [];
f_rllfft a_size a_n a_xs=
let {
r_ls'=f_map2 ((+) :: (Complex_type -> Complex_type -> Complex_type)) r_ls r_rs'';
r_rs'=f_map2 ((-) :: (Complex_type -> Complex_type -> Complex_type)) r_ls r_rs'';
r_rs''=f_map (((*) :: (Complex_type -> Complex_type -> Complex_type)) (f_unitroot a_size a_n)) r_rs;
(r_ls,r_rs)=f_split (((quot) :: (Int -> Int -> Int)) (length a_xs) (2 :: Int)) a_xs
} in (++) (f_rllfft a_size (((quot) :: (Int -> Int -> Int)) a_n (2 :: Int)) r_ls') (f_rllfft a_size (((+) :: (Int -> Int -> Int)) (((quot) :: (Int -> Int -> Int)) a_n (2 :: Int))
(((quot) :: (Int -> Int -> Int)) a_size (4 :: Int))) r_rs');
f_bfly::Int -> Int -> Complex_type -> Complex_type -> (Complex_type,Complex_type);
f_bfly a_i a_n a_x a_y=
let {
r_z=((*) :: (Complex_type -> Complex_type -> Complex_type)) (f_unitroot a_i a_n) a_y
} in (((+) :: (Complex_type -> Complex_type -> Complex_type)) a_x r_z,((-) :: (Complex_type -> Complex_type -> Complex_type)) a_x r_z);
f_unitroot::Int -> Int -> Complex_type;
f_unitroot a_i a_n=
let {
r_phi=((*) :: (Double -> Double -> Double)) (((/) :: (Double -> Double -> Double)) (fromIntegral (((*) :: (Int -> Int -> Int)) (2 :: Int) a_n)) (fromIntegral a_i)) c_pi
} in colon_plus (((cos) :: (Double -> Double)) r_phi) (((sin) :: (Double -> Double)) r_phi);
f_pow2::Int -> Int;
f_pow2 a_x=lshift_i (1 :: Int) a_x;
f_log2::Int -> Int;
f_log2 a_x=floor (f_round_d (((/) :: (Double -> Double -> Double)) (((log) :: (Double -> Double)) (fromIntegral a_x)) (((log) :: (Double -> Double)) (2.00000 :: Double))));
f_round_d::Double -> Double;
f_round_d a_x=entier (((+) :: (Double -> Double -> Double)) a_x (0.500000 :: Double));
f_split::Int -> [t1] -> ([t1],[t1]);
f_split a_n a_xs=(f_take a_n a_xs,f_drop a_n a_xs);
f_join::Int -> [t1] -> [t1] -> [t1];
f_join a_n [] []=[];
f_join a_n a_x a_y=
let {
(r_firstx,r_restx)=f_split a_n a_x;
(r_firsty,r_resty)=f_split a_n a_y
} in (++) r_firstx ((++) r_firsty (f_join a_n r_restx r_resty));
f_reorder::Int -> [t1] -> [t1];
f_reorder 1 a_y=a_y;
f_reorder a_n a_y=
let {
(r_left,r_right)=f_split (((quot) :: (Int -> Int -> Int)) r_size (2 :: Int)) a_y;
r_m=((quot) :: (Int -> Int -> Int)) r_size a_n;