From: sewardj Date: Wed, 3 Feb 1999 17:03:59 +0000 (+0000) Subject: [project @ 1999-02-03 17:03:34 by sewardj] X-Git-Tag: Approximately_9120_patches~6620 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1e4cbfcf578f32d9ea1b407d5c2ed9296638b13f;p=ghc-hetmet.git [project @ 1999-02-03 17:03:34 by sewardj] Changed file organisation of STGhugs to be more like that of MPJ's 990121 (Hugs98 beta) release, making these files redundant. --- diff --git a/ghc/interpreter/charset.c b/ghc/interpreter/charset.c deleted file mode 100644 index a234a28..0000000 --- a/ghc/interpreter/charset.c +++ /dev/null @@ -1,63 +0,0 @@ -/* -------------------------------------------------------------------------- - * Character set handling: - * - * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1 - * character set. The following code provides methods for classifying - * input characters according to the lexical structure specified by the - * report. Hugs should still accept older programs because ASCII is - * essentially just a subset of the ISO character set. - * - * Notes: If you want to port Hugs to a machine that uses something - * substantially different from the ISO character set, then you will need - * to insert additional code to map between character sets. - * - * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256. - * ------------------------------------------------------------------------*/ - -#include "prelude.h" -#include "storage.h" -#include "connect.h" -#include "charset.h" - -unsigned char ctable[NUM_CHARS]; - -Void initCharTab() { /* Initialize char decode table */ -#define setRange(x,f,t) {Int i=f; while (i<=t) ctable[i++] |=x;} -#define setChars(x,s) {char *p=s; while (*p) ctable[(Int)*p++]|=x;} -#define setCopy(x,c) {Int i; \ - for (i=0; i?@\\^|-~"); - - setChars(IDAFTER, "'_"); /* Characters in identifier */ - setCopy (IDAFTER, (DIGIT|SMALL|LARGE)); - - setRange(SPACE, ' ',' '); /* ASCII space character */ - setRange(SPACE, 160,160); /* ISO non breaking space */ - setRange(SPACE, 9,13); /* special whitespace: \t\n\v\f\r */ - - setChars(PRINT, "(),;[]_`{}"); /* Special characters */ - setChars(PRINT, " '\""); /* Space and quotes */ - setCopy (PRINT, (DIGIT|SMALL|LARGE|SYMBOL)); - -#undef setRange -#undef setChars -#undef setCopy -} - diff --git a/ghc/interpreter/charset.h b/ghc/interpreter/charset.h deleted file mode 100644 index e4d7c09..0000000 --- a/ghc/interpreter/charset.h +++ /dev/null @@ -1,31 +0,0 @@ -/* -------------------------------------------------------------------------- - * Character set handling: - * - * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1 - * character set. The following code provides methods for classifying - * input characters according to the lexical structure specified by the - * report. Hugs should still accept older programs because ASCII is - * essentially just a subset of the ISO character set. - * - * Notes: If you want to port Hugs to a machine that uses something - * substantially different from the ISO character set, then you will need - * to insert additional code to map between character sets. - * - * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256. - * ------------------------------------------------------------------------*/ - -extern unsigned char ctable[NUM_CHARS]; - -#define isIn(c,x) (ctable[(Int)(c)]&(x)) -#define isISO(c) (0<=(c) && (c) ([Pat], Rhs') */ - snd(e) = transRhs(snd(e)); -} - -static Void local transCase(c) /* Translate case: */ -Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */ - fst(c) = singleton(fst(c)); - snd(c) = transRhs(snd(c)); -} - -List transBinds(bs) /* Translate list of bindings: */ -List bs; { /* eliminating pattern matching on */ - List newBinds=NIL; /* lhs of bindings. */ - for (; nonNull(bs); bs=tl(bs)) { - if (isVar(fst(hd(bs)))) { - mapProc(transAlt,snd(hd(bs))); - newBinds = cons(hd(bs),newBinds); - } - else - newBinds = remPat(fst(snd(hd(bs))), - snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))), - newBinds); - } - return newBinds; -} - -static Cell local transRhs(rhs) /* Translate rhs: removing line nos */ -Cell rhs; { - switch (whatIs(rhs)) { - case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs))); - return expandLetrec(rhs); - - case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */ - mapProc(transPair,snd(rhs)); - return rhs; - - default : return translate(snd(rhs)); /* discard line number */ - } -} - -Cell mkConsList(es) /* Construct expression for list es */ -List es; { /* using nameNil and nameCons */ - if (isNull(es)) - return nameNil; - else - return ap2(nameCons,hd(es),mkConsList(tl(es))); -} - -static Cell local expandLetrec(root) /* translate LETREC with list of */ -Cell root; { /* groups of bindings (from depend. */ - Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */ - List bss = fst(snd(root)); - Cell temp; - - if (isNull(bss)) /* should never happen, but just in */ - return e; /* case: LETREC [] IN e ==> e */ - - mapOver(transBinds,bss); /* translate each group of bindings */ - - for (temp=root; nonNull(tl(bss)); bss=tl(bss)) { - fst(snd(temp)) = hd(bss); - snd(snd(temp)) = ap(LETREC,pair(NIL,e)); - temp = snd(snd(temp)); - } - fst(snd(temp)) = hd(bss); - - return root; -} - -/* -------------------------------------------------------------------------- - * Translation of list comprehensions is based on the description in - * `The Implementation of Functional Programming Languages': - * - * [ e | qs ] ++ l => transComp e qs l - * transComp e [] l => e : l - * transComp e ((p<-xs):qs) l => LETREC _h [] = l - * _h (p:_xs) = transComp e qs (_h _xs) - * _h (_:_xs) = _h _xs --if p !failFree - * IN _h xs - * transComp e (b:qs) l => if b then transComp e qs l else l - * transComp e (decls:qs) l => LETREC decls IN transComp e qs l - * ------------------------------------------------------------------------*/ - -static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */ -Cell e; -List qs; -Cell l; { - if (nonNull(qs)) { - Cell q = hd(qs); - Cell qs1 = tl(qs); - - switch (fst(q)) { - case FROMQUAL : { Cell ld = NIL; - Cell hVar = inventVar(); - Cell xsVar = inventVar(); - - if (!failFree(fst(snd(q)))) - ld = cons(pair(singleton( - ap2(nameCons, - WILDCARD, - xsVar)), - ap(hVar,xsVar)), - ld); - - ld = cons(pair(singleton( - ap2(nameCons, - fst(snd(q)), - xsVar)), - transComp(e, - qs1, - ap(hVar,xsVar))), - ld); - ld = cons(pair(singleton(nameNil), - l), - ld); - - return ap(LETREC, - pair(singleton(pair(hVar, - ld)), - ap(hVar, - translate(snd(snd(q)))))); - } - - case QWHERE : return - expandLetrec(ap(LETREC, - pair(snd(q), - transComp(e,qs1,l)))); - - case BOOLQUAL : return ap(COND, - triple(translate(snd(q)), - transComp(e,qs1,l), - l)); - } - } - - return ap2(nameCons,e,l); -} - -/* -------------------------------------------------------------------------- - * Translation of monad comprehensions written using do-notation: - * - * do { e } => e - * do { p <- exp; qs } => LETREC _h p = do { qs } - * _h _ = zero{m0} -- if monad with 0 - * IN exp >>={m} _h - * do { LET decls; qs } => LETREC decls IN do { qs } - * do { IF guard; qs } => if guard then do { qs } else zero{m0} - * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h - * - * where m :: Monad f, m0 :: Monad0 f - * ------------------------------------------------------------------------*/ - -static Cell local transDo(m,m0,e,qs) /* Translate do { qs ; e } */ -Cell m; -Cell m0; -Cell e; -List qs; { - if (nonNull(qs)) { - Cell q = hd(qs); - Cell qs1 = tl(qs); - - switch (fst(q)) { - case FROMQUAL : { Cell ld = NIL; - Cell hVar = inventVar(); - - if (!failFree(fst(snd(q))) && nonNull(m0)) - ld = cons(pair(singleton(WILDCARD), - ap(nameZero,m0)),ld); - - ld = cons(pair(singleton(fst(snd(q))), - transDo(m,m0,e,qs1)), - ld); - - return ap(LETREC, - pair(singleton(pair(hVar,ld)), - ap3(nameBind, - m, - translate(snd(snd(q))), - hVar))); - } - - case DOQUAL : { Cell hVar = inventVar(); - Cell ld = cons(pair(singleton(WILDCARD), - transDo(m,m0,e,qs1)), - NIL); - return ap(LETREC, - pair(singleton(pair(hVar,ld)), - ap3(nameBind, - m, - translate(snd(q)), - hVar))); - } - - case QWHERE : return - expandLetrec(ap(LETREC, - pair(snd(q), - transDo(m,m0,e,qs1)))); - - case BOOLQUAL : return ap(COND, - triple(translate(snd(q)), - transDo(m,m0,e,qs1), - ap(nameZero,m0))); - } - } - return e; -} - -/* -------------------------------------------------------------------------- - * Translation of named field construction and update: - * - * Construction is implemented using the following transformation: - * - * C{x1=e1, ..., xn=en} = C v1 ... vm - * where: - * vi = e1, if the ith component of C is labelled with x1 - * ... - * = en, if the ith component of C is labelled with xn - * = undefined, otherwise - * - * Update is implemented using the following transformation: - * - * e{x1=e1, ..., xn=en} - * = let nv (C a1 ... am) v1 ... vn = C a1' .. am' - * nv (D b1 ... bk) v1 ... vn = D b1' .. bk - * ... - * nv _ v1 ... vn = error "failed update" - * in nv e e1 ... en - * where: - * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables, - * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)} - * and: - * ai' = v1, if the ith component of C is labelled with x1 - * ... - * = vn, if the ith component of C is labelled with xn - * = ai, otherwise - * etc... - * - * The error case may be omitted if C,D,... is an enumeration of all of the - * constructors for the datatype concerned. Strictly speaking, error case - * isn't needed at all -- the only benefit of including it is that the user - * will get a "failed update" message rather than a cryptic {v354 ...}. - * So, for now, we'll go with the second option! - * - * For the time being, code for each update operation is generated - * independently of any other updates. However, if updates are used - * frequently, then we might want to consider changing the implementation - * at a later stage to cache definitions of functions like nv above. This - * would create a shared library of update functions, indexed by a set of - * constructors {C,D,...}. - * ------------------------------------------------------------------------*/ - -static Cell local transConFlds(c,flds) /* Translate C{flds} */ -Name c; -List flds; { - Cell e = c; - Int m = name(c).arity; - Int i; - for (i=m; i>0; i--) - e = ap(e,nameUndefined); - for (; nonNull(flds); flds=tl(flds)) { - Cell a = e; - for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--) - a = fun(a); - arg(a) = translate(snd(hd(flds))); - } - return e; -} - -static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */ -Cell e; /* (cs is corresp list of constrs) */ -List cs; -List flds; { - Cell nv = inventVar(); - Cell body = ap(nv,translate(e)); - List fs = flds; - List args = NIL; - List alts = NIL; - - for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */ - Cell b = hd(fs); /* args = [v1, ..., vn] */ - body = ap(body,translate(snd(b))); - args = cons(inventVar(),args); - } - - for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */ - Cell c = hd(cs); /* build up list of alts. */ - Cell pat = c; - Cell rhs = c; - List as = args; - Int m = name(c).arity; - Int i; - - for (i=m; i>0; i--) { /* pat = C a1 ... am */ - Cell a = inventVar(); /* rhs = C a1 ... am */ - pat = ap(pat,a); - rhs = ap(rhs,a); - } - - for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) { - Name s = fst(hd(fs)); /* Replace approp ai in rhs with */ - Cell r = rhs; /* vars from [v1,...,vn] */ - for (i=m-sfunPos(s,c); i>0; i--) - r = fun(r); - arg(r) = hd(as); - } - - alts = cons(pair(cons(pat,args),rhs),alts); - } - return ap(LETREC,pair(singleton(pair(nv,alts)),body)); -} - -/* -------------------------------------------------------------------------- - * Desugar control: - * ------------------------------------------------------------------------*/ - -Void desugarControl(what) -Int what; { - patControl(what); - switch (what) { - case INSTALL : - /* Fall through */ - case RESET : break; - case MARK : break; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/desugar.h b/ghc/interpreter/desugar.h deleted file mode 100644 index 8159162..0000000 --- a/ghc/interpreter/desugar.h +++ /dev/null @@ -1,5 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -extern Cell translate Args((Cell)); -extern Void transAlt Args((Cell)); -extern List transBinds Args((List)); - diff --git a/ghc/interpreter/free.h b/ghc/interpreter/free.h deleted file mode 100644 index c032e72..0000000 --- a/ghc/interpreter/free.h +++ /dev/null @@ -1,2 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -extern List freeVarsBind Args((List, StgVar)); diff --git a/ghc/interpreter/hugs.h b/ghc/interpreter/hugs.h deleted file mode 100644 index 905d684..0000000 --- a/ghc/interpreter/hugs.h +++ /dev/null @@ -1,24 +0,0 @@ -typedef long Target; -extern Void setGoal Args((String, Target)); -extern Void soFar Args((Target)); -extern Void done Args((Void)); - -extern String fromEnv Args((String,String)); -extern Bool chase Args((List)); - - -extern String hugsEdit; /* String for editor command */ -extern String hugsPath; /* String for file search path */ - -extern Cell *CStackBase; /* pointer to base of C stack */ - - - -extern Bool gcMessages; /* TRUE => print GC messages */ -#if DEBUG_CODE -extern Bool debugCode; /* TRUE => print G-code to screen */ -#endif -extern Bool kindExpert; /* TRUE => display kind errors in */ - /* full detail */ -extern Bool allowOverlap; /* TRUE => allow overlapping insts */ - diff --git a/ghc/interpreter/iface.g b/ghc/interpreter/iface.g deleted file mode 100644 index d4885b8..0000000 --- a/ghc/interpreter/iface.g +++ /dev/null @@ -1,304 +0,0 @@ -/**************************************************************** - * Grammar for interface files - ****************************************************************/ - -This document purports to describe the syntax (and semantics?) of -interface files generated by GHC for use by Hugs. - - -/**************************************************************** - * ToDo: - ****************************************************************/ - -o GHC currently generates "Functor( :Functor :Functor map )" in export lists. - This is no longer legal and is very confusing besides - but what - will GHC generate instead? - - -/**************************************************************** - * Closures generated by GHC - ****************************************************************/ - -GHC generates a closure for the following objects (if exported): - -o variables -o instance decls -o methods selectors and superclass selectors -o selector functions (from record syntax) -o data constructors - -If an object foo (respectively Foo) is declared in a module Bar, then -the closure is called Bar_foo_closure (respectively Bar_Foo_closure). - -Whether the object is static or not is not reflected in the name. The -type or arity of the object is not reflected in the name. The name is -just Bar_foo_closure. - -Modifications to the above: - -1) Depending on the architecture, it might be necessary to add a - leading underscore to the name. - -2) We also have to apply the infamous Z-encoding: - - Code from somewhere inside GHC (circa 1994) - * Z-escapes: - "std"++xs -> "Zstd"++xs - char_to_c 'Z' = "ZZ" - char_to_c '&' = "Za" - char_to_c '|' = "Zb" - char_to_c ':' = "Zc" - char_to_c '/' = "Zd" - char_to_c '=' = "Ze" - char_to_c '>' = "Zg" - char_to_c '#' = "Zh" - char_to_c '<' = "Zl" - char_to_c '-' = "Zm" - char_to_c '!' = "Zn" - char_to_c '.' = "Zo" - char_to_c '+' = "Zp" - char_to_c '\'' = "Zq" - char_to_c '*' = "Zt" - char_to_c '_' = "Zu" - char_to_c c = "Z" ++ show (ord c) - - (There's a commented out piece of code in rts/Printer.c which - implements this.) - - -/**************************************************************** - * Lexical syntax - ****************************************************************/ - -The lexical syntax is exactly the same as for Haskell with the -following additions: - -Keywords -~~~~~~~~ - -We add: __export __interface __requires - - -Pragmas -~~~~~~~ - -GHC will use pragmas of the form: {-## ##-}. - -These are always ignored by Hugs and may be ignored by GHC. - -GHC will be able to use lazy parsing for these - just as it - currently does for unfoldings and the like. - - -Compiler generated names -~~~~~~~~~~~~~~~~~~~~~~~~ - -Are of the form _letter(letter|digit|symbol)*. - -It's important that they can always be generated by putting "_l" -in front of a valid Haskell varid, varop, conid or conop. - -It's also important that valid Haskell patterns such as _:_ -should not be valid compiler generated names. - -The letter indicates something about the kind of object it is -but all that Hugs needs to do is separate conid/ops from varid/ops -- which it does depending on whether the letter is uppercase. - - -/**************************************************************** - * Header - ****************************************************************/ - -iface : '__interface' ifaceName NUMLIT version 'where' Body - -Body : '__requires' STRINGLIT ';' - { importDecl ';' } - { instanceImportDecl ';' } - { exportDecl ';' } - { fixityDecl ';' } - { classDecl ';' } - { instanceDecl ';' } - { typeDecl ';' } - { valueDecl ';' } - -version : NUMLIT - -/**************************************************************** - * Import-export stuff - * - * I believe the meaning of 'import' is "qualified import" - but - * I'm not sure. - ADR - ****************************************************************/ - -importDecl : 'import' CONID NUMLIT -instanceImportDecl : 'instance' 'import' CONID NUMLIT -exportDecl : '__export' CONID { Entity } - -Entity : EntityOcc - | EntityOcc StuffInside - | EntityOcc '|' StuffInside - -EntityOcc : Var - | Data - | '->' - | '(' '->' ')' - -StuffInside : '{' ValOcc { ValOcc } '}' - -ValOcc : Var - | Data - -/**************************************************************** - * Fixities - ****************************************************************/ - -fixityDecl : 'infixl' optdigit op - | 'infixr' optdigit op - | 'infix' optdigit op - -/**************************************************************** - * Type declarations - * - * o data decls use "Data" on lhs and rhs to allow this decl: - * - * data () = () - * - * o data declarations don't have the usual Haskell syntax: - * o they don't have strictness annotations - * o they are given an explicit signature instead of a list of - * argument types - * o field selectors are given an explicit signature - * - * [Simon PJ asked me to look again at how much work it would take to - * handle the standard syntax. The answer is: - * o It takes an awful lot of code to process the standard syntax. - * o I can hardly reuse any of the existing code because it is too - * tightly interwoven with other parts of static analysis. - * o The rules for processing data decls are very intricate - * (and are worse since existentials and local polymorphism were - * added). Implementing a complicated thing twice (once in - * GHC and once in Hugs) is bad; implementing it a third time - * is Just Plain Wrong. - * ] - * - * Data decls look like this: - * - * data List a = Nil :: forall [a] => List a - * | Cons{hd,tl} :: forall [a] => a -> List a -> List a - * where - * hd :: forall [a] => List a -> a - * tl :: forall [a] => List a -> List a - * - * o The tyvars on the lhs serve only to help infer the kind of List - * o The type of each data constructor and selector is written - * explicitly. - * o A small amount of work is required to figure out which - * variables are existentially quantified. - * o GHC will require an inlining pragma to recover strictness - * annotations. - ****************************************************************/ - -typeDecl : NUMLIT 'type' TCName {TVBndr} '=' Type - | NUMLIT 'data' Data {TVBndr} ['=' Constrs ['where' Sels]] - | NUMLIT 'newtype' TCName {TVBndr} [ '=' Data AType ] - -Constrs : Constr {'|' Constr} -Constr : Data [Fields] '::' Type -Fields : '{' VarName {',' VarName} '}' - -Sels : Sel {';' Sel} -Sel : VarName '::' ['!'] Type - -/**************************************************************** - * Classes and instances - * - * Question: should the method signature include the class - * constraint? That is, should we write the Eq decl like this: - * - * class Eq a where { (==) :: a -> a -> Bool } -- like Haskell - * - * or like this - * - * class Eq a where { (==) :: Eq a => a -> a -> Bool } - * - * There's not much to choose between them but the second version - * is more consistent with what we're doing with data constructors. - ****************************************************************/ - -classDecl : NUMLIT 'class' [ Context '=>' ] TCName {TVBndr} 'where' CSigs -instanceDecl : 'instance' [Quant] Class '=' Var - -CSigs : '{' CSig { ';' CSigs } '}' -CSig : VarName ['='] '::' Type - -/**************************************************************** - * Types - ****************************************************************/ - -Type : Quant Type - | BType '->' Type - | BType - -Context : '(' Class { ',' Class } ')' - -Class : QTCName { AType } - -BType : AType { AType } - -AType : QTCName - | TVName - | '(' ')' // unit - | '(' Type ')' // parens - | '(' Type ',' Type { ',' Type } ')' // tuple - | '[' Type ']' // list - | '{' QTCName { AType } '}' // dictionary - - -Quant : 'forall' {TVBndr} [Context] '=>' - -TVBndr : TVName [ '::' AKind ] - -Kind : { AKind -> } AKind -AKind : VAROP // really '*' - | '(' Kind ')' - -/**************************************************************** - * Values - ****************************************************************/ - -valueDecl : NUMLIT Var '::' Type - -/**************************************************************** - * Atoms - ****************************************************************/ - -VarName : Var -TVName : VARID - -Var : VARID - | VAROP - | '!' - | '.' - | '-' - -Data : CONID - | CONOP - | '(' ')' - | '[' ']' - -TCName : CONID - | CONOP - | '(' '->' ')' - | '[' ']' - -QTCName : TCName - | QCONID - | QCONOP - -ifaceName : CONID - -/**************************************************************** - * End - ****************************************************************/ - diff --git a/ghc/interpreter/input.h b/ghc/interpreter/input.h deleted file mode 100644 index 9ac35d5..0000000 --- a/ghc/interpreter/input.h +++ /dev/null @@ -1,42 +0,0 @@ -extern String repeatStr; /* Repeat last command string */ - -extern List tyconDefns; /* list of type constructor defns */ -extern List typeInDefns; /* list of synonym restrictions */ -extern List valDefns; /* list of value definitions */ -extern List opDefns; /* list of operator definitions */ -extern List classDefns; /* list of class definitions */ -extern List instDefns; /* list of instance definitions */ -extern List selDefns; /* list of selector lists */ -extern List genDefns; /* list of generated defns */ -extern List foreignImports; /* foreign import declarations */ -extern List foreignExports; /* foreign export declarations */ -extern List defaultDefns; /* default definitions (if any) */ -extern Int defaultLine; /* line in which default defs occur*/ -extern List evalDefaults; /* defaults for evaluator */ -extern Cell inputExpr; /* evaluator input expression */ - -extern Bool literateScripts; /* TRUE => default lit scripts */ -extern Bool literateErrors; /* TRUE => report errs in lit scrs */ - /* termination */ -#if USE_PREPROCESSOR -extern String preprocessor; /* preprocessor command */ -#endif - -extern Cell conPrelude; /* Prelude */ -#if NPLUSK -extern Text textPlus; /* Used to recognise n+k patterns */ -#endif - -extern String unlexChar Args((Char,Char)); -extern Void printString Args((String)); - -extern Void consoleInput Args((String)); -extern Void projInput Args((String)); -extern Void stringInput Args((String)); -extern Void parseScript Args((String,Long)); -extern Void parseInterface Args((String,Long)); -extern Void parseExp Args((Void)); -extern String readFilename Args((Void)); -extern String readLine Args((Void)); - -extern Bool isInterfaceFile Args((String)); diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c deleted file mode 100644 index 817f345..0000000 --- a/ghc/interpreter/interface.c +++ /dev/null @@ -1,910 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * GHC interface file processing for Hugs - * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 - * - * $RCSfile: interface.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:22:15 $ - * ------------------------------------------------------------------------*/ - -/* ToDo: - * o use Z encoding - * o use vectored CONSTR_entry when appropriate - * o generate export list - * - * Needs GHC changes to generate member selectors, - * superclass selectors, etc - * o instance decls - * o dictionary constructors ? - * - * o Get Hugs/GHC to agree on what interface files look like. - * o figure out how to replace the Hugs Prelude with the GHC Prelude - */ - -#include "prelude.h" -#include "storage.h" -#include "connect.h" -#include "static.h" -#include "errors.h" -#include "link.h" -#include "modules.h" -#include "machdep.h" /* for Time */ -#include "input.h" /* for parseInterface */ -#include "type.h" /* for offsetTyVarsIn */ -#include "stg.h" /* for wrapping GHC objects */ -#include "Assembler.h" /* for wrapping GHC objects */ -#include "interface.h" -#include "dynamic.h" - -/* -------------------------------------------------------------------------- - * The "addGHC*" functions act as "impedence matchers" between GHC - * interface files and Hugs. Their main job is to convert abstract - * syntax trees into Hugs' internal representations. - * - * The main trick here is how we deal with mutually recursive interface - * files: - * - * o As we read an import decl, we add it to a list of required imports - * (unless it's already loaded, of course). - * - * o Processing of declarations is split into two phases: - * - * 1) While reading the interface files, we construct all the Names, - * Tycons, etc declared in the interface file but we don't try to - * resolve references to any entities the declaration mentions. - * - * This is done by the "addGHC*" functions. - * - * 2) After reading all the interface files, we finish processing the - * declarations by resolving any references in the declarations - * and doing any other processing that may be required. - * - * This is done by the "finishGHC*" functions which use the - * "fixup*" functions to assist them. - * - * The interface between these two phases are the "ghc*Decls" which - * contain lists of decls that haven't been completed yet. - * - * ------------------------------------------------------------------------*/ - -/* -------------------------------------------------------------------------- - * local variables: - * ------------------------------------------------------------------------*/ - -static List ghcVarDecls; -static List ghcConDecls; -static List ghcSynonymDecls; -static List ghcClassDecls; -static List ghcInstanceDecls; - -/* -------------------------------------------------------------------------- - * local function prototypes: - * ------------------------------------------------------------------------*/ - -static List local addGHCConstrs Args((Int,List,List)); -static Name local addGHCSel Args((Int,Pair,List)); -static Name local addGHCConstr Args((Int,Int,Triple)); - - -static Void local finishGHCVar Args((Name)); -static Void local finishGHCCon Args((Name)); -static Void local finishGHCSynonym Args((Tycon)); -static Void local finishGHCClass Args((Class)); -static Void local finishGHCInstance Args((Inst)); - -static Name local fixupSel Args((Int,Pair,List)); -static Name local fixupConstr Args((Int,Int,Triple)); -static Name local fixupMember Args((Int,Int,Pair)); -static List local fixupMembers Args((Int,List)); -static Type local fixupTypeVar Args((Int,List,Text)); -static Class local fixupClass Args((Int,Text)); -static Cell local fixupPred Args((Int,List,Pair)); -static List local fixupContext Args((Int,List,List)); -static Type local fixupType Args((Int,List,Type)); -static Type local fixupConType Args((Int,Type)); - -static Void local bindNameToClosure Args((Name,AsmClosure)); -static Kinds local tvsToKind Args((List)); -static Int local arityFromType Args((Type)); - -static AsmClosure local lookupGHCClosure Args((Module,Text)); - -/* -------------------------------------------------------------------------- - * code: - * ------------------------------------------------------------------------*/ - -static List interfaces; /* Interface files that haven't been loaded yet */ - -Void loadInterface(String fname) -{ - ghcVarDecls = NIL; - ghcConDecls = NIL; - ghcSynonymDecls = NIL; - ghcClassDecls = NIL; - ghcInstanceDecls = NIL; - - /* Note: interfaces is added to by addGHCImport which is called by - * parseInterface so each time round the loop we remove the - * current interface from the list before calling parseInterface again. - */ - interfaces=singleton(mkCon(findText(fname))); - while (nonNull(interfaces)) { - String fname = textToStr(textOf(hd(interfaces))); - Time timeStamp; /* not used */ - Long fileSize; - getFileInfo(fname, &timeStamp, &fileSize); - interfaces=tl(interfaces); - parseInterface(fname,fileSize); - } - - /* the order of these doesn't matter - * (ToDo: unless synonyms have to be eliminated??) - */ - mapProc(finishGHCVar, ghcVarDecls); - mapProc(finishGHCCon, ghcConDecls); - mapProc(finishGHCSynonym, ghcSynonymDecls); - mapProc(finishGHCClass, ghcClassDecls); - mapProc(finishGHCInstance, ghcInstanceDecls); - ghcVarDecls = NIL; - ghcConDecls = NIL; - ghcSynonymDecls = NIL; - ghcClassDecls = NIL; - ghcInstanceDecls = NIL; -} - -Void openGHCIface(t) -Text t; { - Module m = findModule(t); - if (isNull(m)) { - m = newModule(t); - } else if (m != modulePreludeHugs) { - ERRMSG(0) "Module \"%s\" already loaded", textToStr(t) - EEND; - } - setCurrModule(m); -} - -Void addGHCImport(line,mn,fn) -Int line; -Text mn; -String fn; { -#if 1 /* new */ - Text t = findText(fn); - Module m = findModule(mn); - if (isNull(m)) { - if (isNull(varIsMember(t,interfaces))) { - interfaces = cons(mkCon(t),interfaces); - } - } -#else /* old - and probably wrong */ - Module m = findModule(t); - if (isNull(m)) { - ERRMSG(0) "Unknown module \"%s\"", textToStr(t) - EEND; - } - /* ToDo: what to do if there's a name conflict? */ - { /* copied from resolveImportList */ - List es = module(m).exports; - List imports = NIL; - for(; nonNull(es); es=tl(es)) { - Cell e = hd(es); - if (isName(e)) { - imports = cons(e,imports); - } else { - Cell c = fst(e); - List subentities = NIL; - imports = cons(c,imports); - if (isTycon(c) - && (tycon(c).what == DATATYPE - || tycon(c).what == NEWTYPE)) { - subentities = tycon(c).defn; - } else if (isClass(c)) { - subentities = cclass(c).members; - } - if (DOTDOT == snd(e)) { - imports = revDupOnto(subentities,imports); - } - } - } - map1Proc(importEntity,m,imports); - } -#endif -} - -void addGHCVar(line,v,ty) -Int line; -Text v; -Type ty; -{ - Name n = findName(v); - if (nonNull(n)) { - ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v) - EEND; - } - n = newName(v); - bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text)); - - /* prepare for finishGHCVar */ - name(n).type = ty; - ghcVarDecls = cons(n,ghcVarDecls); -} - -static Void local finishGHCVar(Name n) -{ - Int line = name(n).line; - Type ty = name(n).type; - setCurrModule(name(n).mod); - name(n).type = fixupType(line,NIL,ty); -} - -Void addGHCSynonym(line,tycon,tvs,ty) -Int line; -Cell tycon; /* ConId */ -List tvs; /* [(VarId,Kind)] */ -Type ty; { - /* ToDo: worry about being given a decl for (->) ? - * and worry about qualidents for () - */ - Text t = textOf(tycon); - if (nonNull(findTycon(t))) { - ERRMSG(line) "Repeated definition of type constructor \"%s\"", - textToStr(t) - EEND; - } else { - Tycon tc = newTycon(t); - tycon(tc).line = line; - tycon(tc).arity = length(tvs); - tycon(tc).what = SYNONYM; - tycon(tc).kind = tvsToKind(tvs); - - /* prepare for finishGHCSynonym */ - tycon(tc).defn = pair(tvs,ty); - ghcSynonymDecls = cons(tc,ghcSynonymDecls); - } -} - -static Void local finishGHCSynonym(Tycon tc) -{ - Int line = tycon(tc).line; - List tvs = fst(tycon(tc).defn); - Type ty = snd(tycon(tc).defn); - - setCurrModule(tycon(tc).mod); - tycon(tc).defn = fixupType(line,singleton(tvs),ty); - - /* ToDo: can't really do this until I've done all synonyms - * and then I have to do them in order - * tycon(tc).defn = fullExpand(ty); - */ -} - -Void addGHCDataDecl(line,tycon,tvs,constrs,sels) -Int line; -Cell tycon; /* ConId | QualConId */ -List tvs; /* [(VarId,Kind)] */ -List constrs; /* [(ConId,[VarId],Type)] */ -List sels; { /* [(VarId,Type)] */ - /* ToDo: worry about being given a decl for (->) ? - * and worry about qualidents for () - */ - Text t = textOf(tycon); - if (nonNull(findTycon(t))) { - ERRMSG(line) "Repeated definition of type constructor \"%s\"", - textToStr(t) - EEND; - } else { - Tycon tc = newTycon(t); - tycon(tc).line = line; - tycon(tc).arity = length(tvs); - tycon(tc).what = DATATYPE; - tycon(tc).kind = tvsToKind(tvs); - tycon(tc).defn = addGHCConstrs(line,constrs,sels); - } -} - -static List local addGHCConstrs(line,cons,sels) -Int line; -List cons; /* [(ConId,[VarId],Type)] */ -List sels; { /* [(VarId,Type)] */ - List uses = NIL; /* [(ConName,[VarId])] */ - if (nonNull(cons) && isNull(tl(cons))) { /* Single constructor datatype? */ - List fs = snd3(hd(cons)); - Name c = addGHCConstr(line,0,hd(cons)); - uses = cons(pair(c,fs),uses); - hd(cons) = c; - } else { - Int conNo = 0; /* or maybe 1? */ - List cs = cons; - for(; nonNull(cs); cs=tl(cs), conNo++) { - List fs = snd3(hd(cs)); - Name c = addGHCConstr(line,conNo,hd(cs)); - uses = cons(pair(c,fs),uses); - hd(cs) = c; - } - } - { - List ss = sels; - for(; nonNull(ss); ss=tl(ss)) { - hd(ss) = addGHCSel(line,hd(ss),uses); - } - } - return appendOnto(cons,sels); -} - -static Name local addGHCSel(line,sel,uses) -Int line; -Pair sel; /* (VarId,Type) */ -List uses; { /* [(ConName,[VarId])] */ - Text t = textOf(fst(sel)); - Type type = snd(sel); - List fields = NIL; - - Name n = findName(t); - if (nonNull(n)) { - ERRMSG(line) "Repeated definition for selector \"%s\"", - textToStr(t) - EEND; - } - - n = newName(t); - name(n).line = line; - name(n).number = SELNAME; - name(n).arity = 1; - - for(; nonNull(uses); uses=tl(uses)) { - Int fNo = 1; - Name c = fst(hd(uses)); - List fs = snd(hd(uses)); - for(; nonNull(fs); fs=tl(fs), fNo++) { - if (textOf(hd(fs)) == t) { - fields = cons(pair(c,mkInt(fNo)),fields); - } - } - } - name(n).defn = fields; - - /* prepare for finishGHCVar */ - name(n).type = type; - ghcVarDecls = cons(n,ghcVarDecls); - - return n; -} - -static Name local addGHCConstr(line,conNo,constr) -Int line; -Int conNo; -Triple constr; { /* (ConId,[VarId],Type) */ - /* ToDo: add rank2 annotation and existential annotation - * these affect how constr can be used. - */ - Text con = textOf(fst3(constr)); - Type type = thd3(constr); - Int arity = arityFromType(type); - Name n = findName(con); /* Allocate constructor fun name */ - if (isNull(n)) { - n = newName(con); - } else if (name(n).defn!=PREDEFINED) { - ERRMSG(line) "Repeated definition for constructor \"%s\"", - textToStr(con) - EEND; - } - name(n).arity = arity; /* Save constructor fun details */ - name(n).line = line; - name(n).number = cfunNo(conNo); - bindNameToClosure(n, lookupGHCClosure(name(n).mod,name(n).text)); - - /* prepare for finishGHCCon */ - name(n).type = type; - ghcConDecls = cons(n,ghcConDecls); - - return n; -} - -static Void local finishGHCCon(Name n) -{ - Int line = name(n).line; - Type ty = name(n).type; - setCurrModule(name(n).mod); - name(n).type = fixupConType(line,ty); -} - -Void addGHCNewType(line,tycon,tvs,constr) -Int line; -Cell tycon; /* ConId | QualConId */ -List tvs; /* [(VarId,Kind)] */ -Cell constr; { - /* ToDo: worry about being given a decl for (->) ? - * and worry about qualidents for () - */ - Text t = textOf(tycon); - if (nonNull(findTycon(t))) { - ERRMSG(line) "Repeated definition of type constructor \"%s\"", - textToStr(t) - EEND; - } else { - Tycon tc = newTycon(t); - tycon(tc).line = line; - tycon(tc).arity = length(tvs); - tycon(tc).what = NEWTYPE; - tycon(tc).kind = tvsToKind(tvs); - /* can't really do this until I've read in all synonyms */ - - if (isNull(constr)) { - tycon(tc).defn = NIL; - } else { - /* constr :: (ConId,Type) */ - Text con = textOf(fst(constr)); - Type type = snd(constr); - Name n = findName(con); /* Allocate constructor fun name */ - if (isNull(n)) { - n = newName(con); - } else if (name(n).defn!=PREDEFINED) { - ERRMSG(line) "Repeated definition for constructor \"%s\"", - textToStr(con) - EEND; - } - name(n).arity = 1; /* Save constructor fun details */ - name(n).line = line; - name(n).number = cfunNo(0); - name(n).defn = nameId; - tycon(tc).defn = singleton(n); - - /* prepare for finishGHCCon */ - /* ToDo: we use finishGHCCon instead of finishGHCVar in case - * there's any existential quantification in the newtype - - * but I don't think that's allowed in newtype constrs. - * Still, no harm done by doing it this way... - */ - name(n).type = type; - ghcConDecls = cons(n,ghcConDecls); - } - } -} - -Void addGHCClass(line,ctxt,tc_name,tvs,mems) -Int line; -List ctxt; /* [(ConId, [Type])] */ -Cell tc_name; /* ConId | QualConId */ -List tvs; /* [(VarId,Kind)] */ -List mems; { - Text ct = textOf(tc_name); - if (nonNull(findClass(ct))) { - ERRMSG(line) "Repeated definition of class \"%s\"", - textToStr(ct) - EEND; - } else if (nonNull(findTycon(ct))) { - ERRMSG(line) "\"%s\" used as both class and type constructor", - textToStr(ct) - EEND; - } else { - Class nw = newClass(ct); - Int arity = length(tvs); - Cell head = nw; - Int i; - for(i=0; i < arity; ++i) { - head = ap(head,mkOffset(i)); - } - cclass(nw).line = line; - cclass(nw).arity = arity; - cclass(nw).head = head; - cclass(nw).kinds = tvsToKind(tvs); /* ToDo: I don't think this is right */ - cclass(nw).instances = NIL; - - /* prepare for finishGHCClass */ - cclass(nw).supers = pair(tvs,ctxt); - cclass(nw).members = mems; - ghcClassDecls = cons(nw,ghcClassDecls); - - /* ToDo: - * cclass(nw).dsels = ?; - * cclass(nw).dbuild = ?; - * cclass(nm).dcon = ?; - * cclass(nm).defaults = ?; - */ - } -} - -static Void local finishGHCClass(Class nw) -{ - Int line = cclass(nw).line; - List tvs = fst(cclass(nw).supers); - List ctxt = snd(cclass(nw).supers); - List mems = cclass(nw).members; - - setCurrModule(cclass(nw).mod); - - cclass(nw).supers = fixupContext(line,singleton(tvs),ctxt); - cclass(nw).numSupers = length(cclass(nw).supers); - cclass(nw).members = fixupMembers(line,mems); - cclass(nw).numMembers = length(cclass(nw).members); - cclass(nw).level = 0; /* ToDo: level = 1 + max (map level supers) */ -} - -Void addGHCInstance (line,quant,cls,var) -Int line; -Cell quant; -Pair cls; /* :: (ConId, [Type]) */ -Text var; { - Inst in = newInst(); - - List ctxt = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */ - - inst(in).line = line; - inst(in).implements = NIL; - - { - Name b = newName(inventText()); - name(b).line = line; - name(b).arity = length(ctxt); /* unused? */ - name(b).number = DFUNNAME; - inst(in).builder = b; - bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); - } - - /* prepare for finishGHCInstance */ - inst(in).head = cls; - inst(in).specifics = quant; - ghcInstanceDecls = cons(in,ghcInstanceDecls); -} - -static Void local finishGHCInstance(Inst in) -{ - Int line = inst(in).line; - Cell cl = fst(inst(in).head); - List tys = snd(inst(in).head); - Cell quant = inst(in).specifics; - List tvs = nonNull(quant) ? fst(quant) : NIL; /* [(VarId,Kind)] */ - List ctxt = nonNull(quant) ? snd(quant) : NIL; /* [(ConId, [Type])] */ - List tyvars = singleton(tvs); - Class c; - - setCurrModule(inst(in).mod); - c = findClass(textOf(cl)); - if (isNull(c)) { - ERRMSG(line) "Unknown class \"%s\" in instance", - textToStr(textOf(cl)) - EEND; - } - map2Over(fixupType,line,tyvars,tys); - inst(in).head = applyToArgs(c,tys); - inst(in).specifics = fixupContext(line,tyvars,ctxt); - inst(in).numSpecifics = length(inst(in).specifics); - cclass(c).instances = cons(in,cclass(c).instances); -} - -/* -------------------------------------------------------------------------- - * - * ------------------------------------------------------------------------*/ - -static Name local fixupMember(line,memNo,mem) -Int line; -Int memNo; -Pair mem; { /* :: (Text,Type) */ - Text t = textOf(fst(mem)); - Type type = snd(mem); - Name m = findName(t); - - if (isNull(m)) { - m = newName(t); - } else if (name(m).defn!=PREDEFINED) { - ERRMSG(line) "Repeated definition for member function \"%s\"", - textToStr(t) - EEND; - } - - name(m).line = line; - name(m).arity = 1; - name(m).number = mfunNo(memNo); - name(m).type = fixupType(line,NIL,type); - - /* ToDo: name(m).stgVar = ?; */ - - return m; -} - - -static List local fixupMembers(line,ms) -Int line; -List ms; { - Int memNo = 1; - List mems = ms; - for(; nonNull(mems); mems=tl(mems), memNo++) { - hd(mems) = fixupMember(line,memNo,hd(mems)); - } - return ms; -} - -static Type local fixupTypeVar(line,tyvars,tv) -Int line; -List tyvars; /* [[(VarId,Kind)]] */ -Text tv; { - Int offset = 0; - for (; nonNull(tyvars); tyvars=tl(tyvars)) { - List tvs = hd(tyvars); - for (; nonNull(tvs); offset++, tvs=tl(tvs)) { - if (tv == textOf(fst(hd(tvs)))) { - return mkOffset(offset); - } - } - } - ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv) - EEND; -} - -static Class local fixupClass(line,cls) -Int line; -Text cls; { - Class c = findClass(cls); - if (isNull(c)) { - ERRMSG(line) - "Undefined class \"%s\"", textToStr(cls) - EEND; - } - return c; -} - -static Cell local fixupPred(line,tyvars,pred) -Int line; -List tyvars; /* [[(VarId,Kind)]] */ -Pair pred; { /* (ConId,[Type]) */ - Class c = fixupClass(line,textOf(fst(pred))); - List tys = snd(pred); - - map2Over(fixupType,line,tyvars,tys); - return applyToArgs(c,tys); -} - -static List local fixupContext(line,tyvars,ctxt) -Int line; -List tyvars; /* [[(VarId,Kind)]] */ -List ctxt; { /* [(ConId,[Type])] */ - map2Over(fixupPred,line,tyvars,ctxt); - return ctxt; -} - -static Type local fixupType(line,tyvars,type) -Int line; -List tyvars; /* [[(VarId,Kind)]] */ -Type type; { - switch (whatIs(type)) { - case AP: - { - fst(type) = fixupType(line,tyvars,fst(type)); - snd(type) = fixupType(line,tyvars,snd(type)); - break; - } - case DICTAP: - { - /* Alternatively: raise an error. These can only - * occur in the types of instance variables which - * we could easily separate from "real variables". - */ - snd(type) = fixupPred(line,tyvars,snd(type)); - break; - } - case VARIDCELL: - return fixupTypeVar(line,tyvars,textOf(type)); - case CONIDCELL: - { - Tycon tc = findQualTycon(type); - if (isNull(tc)) { - ERRMSG(line) - "Undefined type constructor \"%s\"", - identToStr(type) - EEND; - } - return tc; - } -#if TREX - case EXT: -#endif - case TYCON: - case TUPLE: - break; - case POLYTYPE: - { - List tvs = fst3(snd(type)); /* [(VarId, Kind)] */ - List ctxt = snd3(snd(type)); /* [(ConId, [Type])] */ - Type ty = thd3(snd(type)); - - if (nonNull(tvs)) { - tyvars = cons(tvs,tyvars); - } - type = fixupType(line,tyvars,ty); - - if (nonNull(ctxt)) { - type = ap(QUAL,pair(fixupContext(line,tyvars,ctxt),type)); - } - if (nonNull(tvs)) { - type = mkPolyType(tvsToKind(tvs),type); - } - } - break; - default: - internal("fixupType"); - } - return type; -} - -/* forall as bs. C1 as, C2 as bs => Ts as bs -> T as - * => forall as. C1 as => exists bs. C2 as bs => Ts as bs -> T as - */ -static Type local fixupConType(line,type) -Int line; -Type type; { - List sig = NIL; - List ctxt = NIL; - type = fixupType(line,NIL,type); - - if (isPolyType(type)) { - sig = polySigOf(type); - type = monotypeOf(type); - } - if (whatIs(type) == QUAL) { - ctxt = fst(snd(type)); - type = snd(snd(type)); - } - { - Type r_ty = type; - Int nr2 = 0; /* maximum argnum which is a polytype */ - Int argnum = 1; - while (isAp(r_ty) && getHead(r_ty)==typeArrow) { - if (isPolyType(arg(fun(r_ty)))) { - nr2 = argnum; - } - argnum++; - r_ty = arg(r_ty); - } - - if (nr2>0) { - type = ap(RANK2,pair(mkInt(nr2),type)); - } - { /* tyvars which don't appear in result are existentially quant'd */ - List result_tvs = offsetTyvarsIn(r_ty,NIL); - List all_tvs = offsetTyvarsIn(type,NIL); - Int etvs = length(all_tvs); - Int ntvs = length(result_tvs); - if (etvs>ntvs) { - /* ToDo: split the context into two parts */ - type = ap(EXIST,pair(mkInt(etvs-ntvs),type)); - } - } - } - if (nonNull(ctxt)) { - type = ap(QUAL,pair(ctxt,type)); - } - if (nonNull(sig)) { - type = mkPolyType(sig,type); - } - return type; -} - -/* -------------------------------------------------------------------------- - * Utilities - * - * None of these do lookups or require that lookups have been resolved - * so they can be performed while reading interfaces. - * ------------------------------------------------------------------------*/ - -static Kinds local tvsToKind(tvs) -List tvs; { /* [(VarId,Kind)] */ - List rs = NIL; - Kinds r = STAR; /* ToDo: hope this works */ - for(; nonNull(tvs); tvs=tl(tvs)) { /* make reversed list of kinds */ - rs = cons(snd(hd(tvs)),rs); - } - for(; nonNull(rs); rs=tl(rs)) { /* build full kind */ - r = ap(hd(rs),r); - } - return r; -} - -static Int local arityFromType(type) /* arity of a constructor with this type */ -Type type; { - Int arity = 0; - if (isPolyType(type)) { - type = monotypeOf(type); - } - if (whatIs(type) == QUAL) { - type = snd(snd(type)); - } - if (whatIs(type) == EXIST) { - type = snd(snd(type)); - } - if (whatIs(type)==RANK2) { - type = snd(snd(type)); - } - while (isAp(type) && getHead(type)==typeArrow) { - arity++; - type = arg(type); - } - return arity; -} - -/* -------------------------------------------------------------------------- - * Dynamic loading code (probably shouldn't be here) - * - * o .hi file explicitly says which .so file to load. - * This avoids the need for a 1-to-1 relationship between .hi and .so files. - * - * ToDo: when doing a :reload, we ought to check the modification date - * on the .so file. - * - * o module handles are unloaded (dlclosed) when we call dropScriptsFrom. - * - * ToDo: do the same for foreign functions - but with complication that - * there may be multiple .so files - * ------------------------------------------------------------------------*/ - -/* ToDo: move some of this code (back) into dynamic.c and make it portable */ -#include - -static AsmClosure local lookupGHCClosure( Module m, Text t ) -{ - char symbol[100]; /* ToDo: arbitrary constants must die */ - void *c; - sprintf(symbol,"%s_%s_closure",textToStr(module(m).text),textToStr(t)); - if (module(m).objectFile == NULL) { - ERRMSG(0) "Interface file must \"require\" at least one file" - EEND; - } - c = lookupSymbol(module(m).objectFile,symbol); - if (NULL == c) { - ERRMSG(0) "Error %s while importing symbol \"%s\"", dlerror(), symbol - EEND; - } - return ((AsmClosure)c); -} - -Void loadSharedLib( String fn ) -{ - if (module(currentModule).objectFile != NULL) { - ERRMSG(0) "Interface file \"require\"s two files" - EEND; - } - module(currentModule).objectFile = loadLibrary(fn); - if (NULL == module(currentModule).objectFile) { - ERRMSG(0) "Error %s while importing DLL \"%s\"", dlerror(), fn - EEND; - } -} - -static void bindNameToClosure(n,c) -Name n; -AsmClosure c; { - StgVar v = mkStgVar(NIL,mkPtr(asmMkObject(c))); - name(n).stgVar = v; -} - -/* -------------------------------------------------------------------------- - * Control: - * ------------------------------------------------------------------------*/ - -Void interface(what) -Int what; { - switch (what) { - case RESET: - interfaces = NIL; - ghcVarDecls = NIL; - ghcConDecls = NIL; - ghcSynonymDecls = NIL; - ghcClassDecls = NIL; - ghcInstanceDecls = NIL; - break; - case MARK: - mark(interfaces); - mark(ghcVarDecls); - mark(ghcConDecls); - mark(ghcSynonymDecls); - mark(ghcClassDecls); - mark(ghcInstanceDecls); - break; - } -} - -/*-------------------------------------------------------------------------*/ - diff --git a/ghc/interpreter/interface.h b/ghc/interpreter/interface.h deleted file mode 100644 index 16178d0..0000000 --- a/ghc/interpreter/interface.h +++ /dev/null @@ -1,14 +0,0 @@ -/* -*- mode: hugs-c; -*- */ - -extern Void loadInterface Args((String)); - -extern Void openGHCIface Args((Text)); -extern Void loadSharedLib Args((String)); -extern Void addGHCImport Args((Int,Text,String)); -extern Void addGHCVar Args((Int,Text,Type)); -extern Void addGHCSynonym Args((Int,Cell,List,Type)); -extern Void addGHCDataDecl Args((Int,Cell,List,List,List)); -extern Void addGHCNewType Args((Int,Cell,List,Cell)); -extern Void addGHCClass Args((Int,List,Cell,List,List)); -extern Void addGHCInstance Args((Int,Cell,Pair,Text)); - diff --git a/ghc/interpreter/kind.c b/ghc/interpreter/kind.c deleted file mode 100644 index 6584def..0000000 --- a/ghc/interpreter/kind.c +++ /dev/null @@ -1,429 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * Part of type checker dealing with kind inference - * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 - * - * $RCSfile: kind.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:22:16 $ - * ------------------------------------------------------------------------*/ - -#define newKindvars(n) newTyvars(n) /* to highlight uses of type vars */ - /* as kind variables */ - -Bool kindExpert = FALSE; /* TRUE => display kind errors in */ - /* full detail */ - -/* -------------------------------------------------------------------------- - * Kind checking code: - * ------------------------------------------------------------------------*/ - -static Void local kindError(l,c,in,wh,k,o) -Int l; /* line number near constuctor exp */ -Constr c; /* constructor */ -Constr in; /* context (if any) */ -String wh; /* place in which error occurs */ -Kind k; /* expected kind (k,o) */ -Int o; { /* inferred kind (typeIs,typeOff) */ - clearMarks(); - - if (!kindExpert) { /* for those with a fear of kinds */ - ERRMSG(l) "Illegal type" ETHEN - if (nonNull(in)) { - ERRTEXT " \"" ETHEN ERRTYPE(in); - ERRTEXT "\"" ETHEN - } - ERRTEXT " in %s\n", wh - EEND; - } - - ERRMSG(l) "Kind error in %s", wh ETHEN - if (nonNull(in)) { - ERRTEXT "\n*** expression : " ETHEN ERRTYPE(in); - } - ERRTEXT "\n*** constructor : " ETHEN ERRTYPE(c); - ERRTEXT "\n*** kind : " ETHEN ERRKIND(copyType(typeIs,typeOff)); - ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o)); - if (unifyFails) { - ERRTEXT "\n*** because : %s", unifyFails ETHEN - } - ERRTEXT "\n" - EEND; -} - -#define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \ - kindError(l,c,in,wh,k,o) -#define checkKind(l,c,in,wh,k,o) kindConstr(l,c); shouldKind(l,c,in,wh,k,o) -#define inferKind(k,o) typeIs=k; typeOff=o - -static Int locCVars; /* offset to local variable kinds */ -static List unkindTypes; /* types in need of kind annotation*/ -#if TREX -static Kind extKind; /* Kind of extension, *->row->row */ -#endif - -static Void local kindConstr(l,c) /* Determine kind of constructor */ -Int l; -Cell c; { - Cell h = getHead(c); - Int n = argCount; - - if (isSynonym(h) && n ... -> vn -> w */ - shouldKind(l,h,c,app,k,beta); - - for (i=n; i>0; --i) { /* ci :: vi for each 1 <- 1..n */ - checkKind(l,arg(a),c,app,var,beta+i-1); - a = fun(a); - } - tyvarType(beta+n); /* inferred kind is w */ - } -} - -static Kind local kindAtom(c) /* Find kind of atomic constructor */ -Cell c; { - switch (whatIs(c)) { - case TUPLE : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */ - case OFFSET : return mkInt(locCVars+offsetOf(c)); - case TYCON : return tycon(c).kind; -#if TREX - case EXT : return extKind; -#endif - } - internal("kindAtom"); - return STAR;/* not reached */ -} - -static Void local kindPred(line,pred) /* Check kinds of arguments in pred*/ -Int line; -Cell pred; { - static String predicate = "class constraint"; -#if TREX - if (isExt(fun(pred))) { - checkKind(line,arg(pred),NIL,predicate,ROW,0); - return; - } -#endif - checkKind(line,arg(pred),NIL,predicate,cclass(fun(pred)).sig,0); -} - -static Void local kindType(line,wh,type)/* check that (poss qualified) type*/ -Int line; /* is well-kinded */ -String wh; -Type type; { - locCVars = 0; - if (isPolyType(type)) { /* local constructor vars reqd? */ - Kind k = polySigOf(type); - Int n = 0; - for (; isPair(k); k=snd(k)) - n++; - locCVars = newKindvars(n); - unkindTypes = cons(pair(mkInt(locCVars),snd(type)),unkindTypes); - type = monoTypeOf(type); - } - if (whatIs(type)==QUAL) { /* examine context (if any) */ - map1Proc(kindPred,line,fst(snd(type))); - type = snd(snd(type)); - } - checkKind(line,type,NIL,wh,STAR,0); /* finally, check type part */ -} - -static Void local fixKinds() { /* add kind annotations to types */ - for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) { - Pair pr = hd(unkindTypes); - Int beta = intOf(fst(pr)); - Cell qts = fst(snd(pr)); - for (;;) { - if (isNull(hd(qts))) - hd(qts) = copyKindvar(beta++); - else - hd(qts) = ap(hd(qts),copyKindvar(beta++)); - if (nonNull(tl(qts))) - qts = tl(qts); - else { - tl(qts) = STAR; - break; - } - } -#ifdef DEBUG_KINDS - Printf("Type expression: "); - printType(stdout,snd(snd(pr))); - Printf(" :: "); - printKind(stdout,fst(snd(pr))); - Printf("\n"); -#endif - } -} - -/* -------------------------------------------------------------------------- - * Kind checking of groups of type constructors and classes: - * ------------------------------------------------------------------------*/ - -Void kindTCGroup(tcs) /* find kinds for mutually rec. gp */ -List tcs; { /* of tycons and classes */ - typeChecker(RESET); - mapProc(initTCKind,tcs); - mapProc(kindTC,tcs); - mapProc(genTC,tcs); - fixKinds(); - typeChecker(RESET); -} - -static Void local initTCKind(c) /* build initial kind/arity for c */ -Cell c; { - if (isTycon(c)) { /* Initial kind of tycon is: */ - Int beta = newKindvars(1); /* v1 -> ... -> vn -> vn+1 */ - varKind(tycon(c).arity); /* where n is the arity of c. */ - bindTv(beta,typeIs,typeOff); /* For data definitions, vn+1 == * */ - switch (whatIs(tycon(c).what)) { - case NEWTYPE : - case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0); - } - tycon(c).kind = mkInt(beta); - } - else - cclass(c).sig = mkInt(newKindvars(1)); -} - -static Void local kindTC(c) /* check each part of a tycon/class*/ -Cell c; { /* is well-kinded */ - if (isTycon(c)) { - static String cfun = "constructor function"; - static String tsyn = "synonym definition"; - Int line = tycon(c).line; - - locCVars = tyvar(intOf(tycon(c).kind))->offs; - switch (whatIs(tycon(c).what)) { - case NEWTYPE : - case DATATYPE : { List cs = tycon(c).defn; - if (whatIs(cs)==QUAL) { - map1Proc(kindPred,line,fst(snd(cs))); - tycon(c).defn = cs = snd(snd(cs)); - } - for (; hasCfun(cs); cs=tl(cs)) - kindType(line,cfun,name(hd(cs)).type); - break; - } - - default : checkKind(line,tycon(c).defn,NIL, - tsyn,var,locCVars+tycon(c).arity); - } - } - else { /* scan type exprs in class defn to*/ - List ms = cclass(c).members; /* determine the class signature */ - List scs = cclass(c).supers; - - for (; nonNull(scs); scs=tl(scs)) - if (!kunify(cclass(hd(scs)).sig,0,cclass(c).sig,0)) { - ERRMSG(cclass(c).line) - "Kind of class \"%s\" does not match superclass \"%s\"", - textToStr(cclass(c).text), textToStr(cclass(hd(scs)).text) - EEND; - } - - for (; nonNull(ms); ms=tl(ms)) { - Int line = intOf(fst3(hd(ms))); - Type type = thd3(hd(ms)); - kindType(line,"member function type signature",type); - } - } -} - -static Void local genTC(c) /* generalise kind inferred for */ -Cell c; { /* given tycon/class */ - if (isTycon(c)) { - tycon(c).kind = copyKindvar(intOf(tycon(c).kind)); -#ifdef DEBUG_KINDS - Printf("%s :: ",textToStr(tycon(c).text)); - printKind(stdout,tycon(c).kind); - Putchar('\n'); -#endif - } - else { - cclass(c).sig = copyKindvar(intOf(cclass(c).sig)); -#ifdef DEBUG_KINDS - Printf("%s :: ",textToStr(cclass(c).text)); - printKind(stdout,cclass(c).sig); - Putchar('\n'); -#endif - } -} - -static Kind local copyKindvar(vn) /* build kind attatched to variable*/ -Int vn; { - Tyvar *tyv = tyvar(vn); - if (tyv->bound) - return copyKind(tyv->bound,tyv->offs); - return STAR; /* any unbound variable defaults to*/ -} /* the kind of all types */ - -static Kind local copyKind(k,o) /* build kind expression from */ -Kind k; /* given skeleton */ -Int o; { - switch (whatIs(k)) { - case AP : { Kind l = copyKind(fst(k),o); /* ensure correct */ - Kind r = copyKind(snd(k),o); /* eval. order */ - return ap(l,r); - } - case OFFSET : return copyKindvar(o+offsetOf(k)); - case INTCELL : return copyKindvar(intOf(k)); - } - return k; -} - -/* -------------------------------------------------------------------------- - * Kind checking of instance declaration headers: - * ------------------------------------------------------------------------*/ - -Void kindInst(in,h) /* check predicates in instance */ -Inst in; -Cell h; { - typeChecker(RESET); - locCVars = newKindvars(inst(in).arity); - kindPred(inst(in).line,h); - map1Proc(kindPred,inst(in).line,inst(in).specifics); - typeChecker(RESET); -} - -/* -------------------------------------------------------------------------- - * Kind checking of individual type signatures: - * ------------------------------------------------------------------------*/ - -Void kindSigType(line,type) /* check that type is well-kinded */ -Int line; -Type type; { - typeChecker(RESET); - kindType(line,"type expression",type); - fixKinds(); - typeChecker(RESET); -} - -/* -------------------------------------------------------------------------- - * Kind checking of default types: - * ------------------------------------------------------------------------*/ - -Void kindDefaults(line,ts) /* check that list of types are */ -Int line; /* well-kinded */ -List ts; { - typeChecker(RESET); - map2Proc(kindType,line,"default type",ts); - fixKinds(); - typeChecker(RESET); -} - -/* -------------------------------------------------------------------------- - * Support for `kind preserving substitutions' from unification: - * ------------------------------------------------------------------------*/ - -static Bool local eqKind(k1,k2) /* check that two (mono)kinds are */ -Kind k1, k2; { /* equal */ - return k1==k2 - || (isPair(k1) && isPair(k2) - && eqKind(fst(k1),fst(k2)) - && eqKind(snd(k1),snd(k2))); -} - -static Kind local getKind(c,o) /* Find kind of constr during type */ -Cell c; /* checking process */ -Int o; { - if (isAp(c)) /* application */ - return snd(getKind(fst(c),o)); - switch (whatIs(c)) { - case TUPLE : return simpleKind(tupleOf(c)); /* (,) :: * -> * -> * */ - case OFFSET : return tyvar(o+offsetOf(c))->kind; - case INTCELL: return tyvar(intOf(c))->kind; - case TYCON : return tycon(c).kind; -#if TREX - case EXT : return extKind; -#endif - } -#ifdef DEBUG_KINDS - Printf("getKind c = %d, whatIs=%d\n",c,whatIs(c)); -#endif - internal("getKind"); - return STAR;/* not reached */ -} - -/* -------------------------------------------------------------------------- - * Two forms of kind expression are used quite frequently: - * * -> * -> ... -> * -> * for kinds of ->, [], ->, (,) etc... - * v1 -> v2 -> ... -> vn -> vn+1 skeletons for constructor kinds - * Expressions of these forms are produced by the following functions which - * use a cache to avoid repeated construction of commonly used values. - * A similar approach is used to store the types of tuple constructors in the - * main type checker. - * ------------------------------------------------------------------------*/ - -#define MAXKINDFUN 10 -static Kind simpleKindCache[MAXKINDFUN]; -static Kind varKindCache[MAXKINDFUN]; - -static Kind local makeSimpleKind(n) /* construct * -> ... -> * (n args)*/ -Int n; { - Kind k = STAR; - while (n-- > 0) - k = ap(STAR,k); - return k; -} - -static Kind local simpleKind(n) /* return (possibly cached) simple */ -Int n; { /* function kind */ - if (n>=MAXKINDFUN) - return makeSimpleKind(n); - else if (nonNull(simpleKindCache[n])) - return simpleKindCache[n]; - else if (n==0) - return simpleKindCache[0] = STAR; - else - return simpleKindCache[n] = ap(STAR,simpleKind(n-1)); -} - -static Kind local makeVarKind(n) /* construct v0 -> .. -> vn */ -Int n; { - Kind k = mkOffset(n); - while (n-- > 0) - k = ap(mkOffset(n),k); - return k; -} - -static Void local varKind(n) /* return (possibly cached) var */ -Int n; { /* function kind */ - typeOff = newKindvars(n+1); - if (n>=MAXKINDFUN) - typeIs = makeVarKind(n); - else if (nonNull(varKindCache[n])) - typeIs = varKindCache[n]; - else - typeIs = varKindCache[n] = makeVarKind(n); -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/lift.h b/ghc/interpreter/lift.h deleted file mode 100644 index c7d8c74..0000000 --- a/ghc/interpreter/lift.h +++ /dev/null @@ -1,3 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -extern List liftBinds( List binds ); -extern Void liftControl ( Int what ); diff --git a/ghc/interpreter/machdep.h b/ghc/interpreter/machdep.h deleted file mode 100644 index bc1037f..0000000 --- a/ghc/interpreter/machdep.h +++ /dev/null @@ -1,145 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/*--------------------------------------------------------------------------- - * Interrupting execution (signals, allowBreak): - *-------------------------------------------------------------------------*/ - -extern Bool breakOn Args((Bool)); - -extern Bool broken; /* indicates interrupt received */ - -#ifndef SIGBREAK /* Sigh, not defined in cygwin32 beta release 16 */ -# define SIGBREAK 21 -#endif - -/* allowBreak: call to allow user to interrupt computation - * ctrlbrk: set control break handler - */ - -#if HUGS_FOR_WINDOWS -# define ctrlbrk(bh) -# define allowBreak() kbhit() -#else /* !HUGS_FOR_WINDOWS */ -# define ctrlbrk(bh) signal(SIGINT,bh); signal(SIGBREAK,bh) -# define allowBreak() if (broken) { broken=FALSE; sigRaise(breakHandler); } -#endif /* !HUGS_FOR_WINDOWS */ - -/*--------------------------------------------------------------------------- - * Environment variables and the registry - *-------------------------------------------------------------------------*/ - -/* On Win32 we can use the registry to supplement info in environment - * variables. - */ -#define USE_REGISTRY (HAVE_WINDOWS_H && !__MSDOS__) - -#ifdef USE_REGISTRY -Bool writeRegString Args((String var, String val)); -String readRegString Args((String var, String def)); -Int readRegInt Args((String var, Int def)); -Bool writeRegInt Args((String var, Int val)); -#endif - -/*--------------------------------------------------------------------------- - * File operations: - *-------------------------------------------------------------------------*/ - -#if HAVE_UNISTD_H -# include -# include -#elif !HUGS_FOR_WINDOWS -extern int chdir Args((const char*)); -#endif - -#if HAVE_STDLIB_H -# include -#else -extern int system Args((const char *)); -extern double atof Args((const char *)); -extern void exit Args((int)); -#endif - -#ifndef FILENAME_MAX /* should already be defined in an ANSI compiler*/ -#define FILENAME_MAX 256 -#else -#if FILENAME_MAX < 256 -#undef FILENAME_MAX -#define FILENAME_MAX 256 -#endif -#endif - -/* Hack, hack: if you have dos.h, you probably have a DOS filesystem */ -#define DOS_FILENAMES HAVE_DOS_H -/* ToDo: can we replace this with a feature test? */ -#define MAC_FILENAMES SYMANTEC_C - -#define CASE_INSENSITIVE_FILENAMES (DOS_FILENAMES | RISCOS) - -#if CASE_INSENSITIVE_FILENAMES -# if HAVE_STRCASECMP -# define filenamecmp(s1,s2) strcasecmp(s1,s2) -# elif HAVE__STRICMP -# define filenamecmp(s1,s2) _stricmp(s1,s2) -# elif HAVE_STRICMP -# define filenamecmp(s1,s2) stricmp(s1,s2) -# elif HAVE_STRCMPI -# define filenamecmp(s1,s2) strcmpi(s1,s2) -# endif -#else -# define filenamecmp(s1,s2) strcmp(s1,s2) -#endif - -/*--------------------------------------------------------------------------- - * Pipe-related operations: - * - * On Windows, many standard Unix names acquire a leading underscore. - * Irritating, but easy to work around. - *-------------------------------------------------------------------------*/ - -#if !defined(HAVE_POPEN) && defined(HAVE__POPEN) -#define popen(x,y) _popen(x,y) -#endif -#if !defined(HAVE_PCLOSE) && defined(HAVE__PCLOSE) -#define pclose(x) _pclose(x) -#endif - -/*--------------------------------------------------------------------------- - * Bit manipulation: - *-------------------------------------------------------------------------*/ - -#define bitArraySize(n) ((n)/bitsPerWord + 1) -#define placeInSet(n) ((-(n)-1)>>wordShift) -#define maskInSet(n) (1<<((-(n)-1)&wordMask)) - -/*--------------------------------------------------------------------------- - * Function prototypes for code in machdep.c - *-------------------------------------------------------------------------*/ - -#if RISCOS -typedef struct { unsigned hi, lo; } Time; -#define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo) -#define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo -#else -typedef time_t Time; -#define timeChanged(now,thn) (now!=thn) -#define timeSet(var,tm) var = tm -#endif - -extern Void getFileInfo Args((String, Time *, Long *)); -extern int pathCmp Args((String, String)); -extern String substPath Args((String,String)); -extern Bool startEdit Args((Int,String)); - -extern String findPathname Args((String,String)); -extern String findMPathname Args((String,String)); - -extern Int shellEsc Args((String)); -extern Int getTerminalWidth Args((Void)); -extern Void normalTerminal Args((Void)); -extern Void noechoTerminal Args((Void)); -extern Int readTerminalChar Args((Void)); -extern Void gcStarted Args((Void)); -extern Void gcScanning Args((Void)); -extern Void gcRecovered Args((Int)); -extern Void gcCStack Args((Void)); - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/modules.c b/ghc/interpreter/modules.c deleted file mode 100644 index e833c61..0000000 --- a/ghc/interpreter/modules.c +++ /dev/null @@ -1,465 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * Import-Export processing for Hugs - * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 - * - * $RCSfile: modules.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:22:21 $ - * ------------------------------------------------------------------------*/ - -#include "prelude.h" -#include "storage.h" -#include "static.h" -#include "errors.h" -#include "link.h" -#include "modules.h" - -/* -------------------------------------------------------------------------- - * local function prototypes: - * ------------------------------------------------------------------------*/ - -static Name local lookupName Args((Text,List)); -static List local checkSubentities Args((List,List,List,String,Text)); -static List local checkExportTycon Args((List,Text,Cell,Tycon)); -static List local checkExportClass Args((List,Text,Cell,Class)); -static List local checkExport Args((List,Text,Cell)); -static List local checkImportEntity Args((List,Module,Cell)); -static List local resolveImportList Args((Module,Cell)); - -static Void local importName Args((Module,Name)); -static Void local importTycon Args((Module,Tycon)); -static Void local importClass Args((Module,Class)); - -/* -------------------------------------------------------------------------- - * Static analysis of modules: - * ------------------------------------------------------------------------*/ - -Void startModule(nm) /* switch to a new module */ -Cell nm; { - Module m; - if (!isCon(nm)) internal("startModule"); - if (isNull(m = findModule(textOf(nm)))) { - m = newModule(textOf(nm)); - } else if (m != modulePreludeHugs) { - ERRMSG(0) "Module \"%s\" already loaded", textToStr(textOf(nm)) - EEND; - } - setCurrModule(m); -} - -Void setExportList(exps) /* Add export list to current module */ -List exps; { - module(currentModule).exports = exps; -} - -Void addQualImport(orig,new) /* Add to qualified import list */ -Cell orig; /* Original name of module */ -Cell new; { /* Name module is called within this module (or NIL) */ - module(currentModule).qualImports = - cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports); -} - -Void addUnqualImport(mod,entities) /* Add to unqualified import list */ -Cell mod; /* Name of module */ -List entities; { /* List of entity names */ - unqualImports = cons(pair(mod,entities),unqualImports); -} - -Void checkQualImport(i) /* Process qualified import */ -Pair i; { - Module m = findModid(snd(i)); - if (isNull(m)) { - ERRMSG(0) "Module \"%s\" not previously loaded", - textToStr(textOf(snd(i))) - EEND; - } - snd(i)=m; -} - -Void checkUnqualImport(i) /* Process unqualified import */ -Pair i; { - Module m = findModid(fst(i)); - if (isNull(m)) { - ERRMSG(0) "Module \"%s\" not previously loaded", - textToStr(textOf(fst(i))) - EEND; - } - fst(i)=m; -} - -static Name local lookupName(t,nms) /* find text t in list of Names */ -Text t; -List nms; { /* :: [Name] */ - for(; nonNull(nms); nms=tl(nms)) { - if (t == name(hd(nms)).text) - return hd(nms); - } - return NIL; -} - -static List local checkSubentities(imports,named,wanted,description,textParent) -List imports; -List named; /* :: [ Q?(Var|Con)(Id|Op) ] */ -List wanted; /* :: [Name] */ -String description; /* "| of |" */ -Text textParent; { - for(; nonNull(named); named=tl(named)) { - Pair x = hd(named); - /* ToDo: ignores qualifier; doesn't check that entity is in scope */ - Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x); - Name n = lookupName(t,wanted); - if (isNull(n)) { - ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"", - textToStr(t), - description, - textToStr(textParent) - EEND; - } - imports = cons(n,imports); - } - return imports; -} - -static List local checkImportEntity(imports,exporter,entity) -List imports; /* Accumulated list of things to import */ -Module exporter; -Cell entity; { /* Entry from import list */ - List oldImports = imports; - Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity)); - List es = module(exporter).exports; - for(; nonNull(es); es=tl(es)) { - Cell e = hd(es); /* :: Entity | (Entity, NIL|DOTDOT) */ - if (isPair(e)) { - Cell f = fst(e); - if (isTycon(f)) { - if (tycon(f).text == t) { - imports = cons(f,imports); - if (!isIdent(entity)) { - switch (tycon(f).what) { - case NEWTYPE: - case DATATYPE: - if (DOTDOT == snd(entity)) { - imports=revDupOnto(tycon(f).defn,imports); - } else { - imports=checkSubentities(imports,snd(entity),tycon(f).defn,"constructor of type",t); - } - break; - default:; - /* deliberate fall thru */ - } - } - } - } else if (isClass(f)) { - if (cclass(f).text == t) { - imports = cons(f,imports); - if (!isIdent(entity)) { - if (DOTDOT == snd(entity)) { - return revDupOnto(cclass(f).members,imports); - } else { - return checkSubentities(imports,snd(entity),cclass(f).members,"member of class",t); - } - } - } - } else { - internal("checkImportEntity2"); - } - } else if (isName(e)) { - if (isIdent(entity) && name(e).text == t) { - imports = cons(e,imports); - } - } else { - internal("checkImportEntity3"); - } - } - if (imports == oldImports) { - ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"", - textToStr(t), - textToStr(module(exporter ).text) - EEND; - } - return imports; -} - -static List local resolveImportList(m,impList) -Module m; /* exporting module */ -Cell impList; { - List imports = NIL; - if (DOTDOT == impList) { - List es = module(m).exports; - for(; nonNull(es); es=tl(es)) { - Cell e = hd(es); - if (isName(e)) { - imports = cons(e,imports); - } else { - Cell c = fst(e); - List subentities = NIL; - imports = cons(c,imports); - if (isTycon(c) - && (tycon(c).what == DATATYPE - || tycon(c).what == NEWTYPE)) - subentities = tycon(c).defn; - else if (isClass(c)) - subentities = cclass(c).members; - if (DOTDOT == snd(e)) { - imports = revDupOnto(subentities,imports); - } - } - } - } else { - map1Accum(checkImportEntity,imports,m,impList); - } - return imports; -} - -Void checkImportList(thisModule,importSpec) /* Import a module unqualified */ -Module thisModule; -Pair importSpec; { - Module m = fst(importSpec); - Cell impList = snd(importSpec); - - List imports = NIL; /* entities we want to import */ - List hidden = NIL; /* entities we want to hide */ - - if (m == thisModule) { - ERRMSG(0) "Module \"%s\" recursively imports itself", - textToStr(module(m).text) - EEND; - } - if (isPair(impList) && HIDDEN == fst(impList)) { - /* Somewhat inefficient - but obviously correct: - * imports = importsOf("module Foo") `setDifference` hidden; - */ - hidden = resolveImportList(m, snd(impList)); - imports = resolveImportList(m, DOTDOT); - } else { - imports = resolveImportList(m, impList); - } - for(; nonNull(imports); imports=tl(imports)) { - Cell e = hd(imports); - if (!cellIsMember(e,hidden)) - importEntity(m,e); - } - /* ToDo: hang onto the imports list for processing export list entries - * of the form "module Foo" - */ -} - -Void importEntity(source,e) -Module source; -Cell e; { - switch (whatIs(e)) { - case NAME : importName(source,e); - break; - case TYCON : importTycon(source,e); - break; - case CLASS : importClass(source,e); - break; - default: internal("importEntity"); - } -} - -static Void local importName(source,n) -Module source; -Name n; { - Name clash = addName(n); - if (nonNull(clash) && clash!=n) { - ERRMSG(0) "Entity \"%s\" imported from module \"%s\" already defined in module \"%s\"", - textToStr(name(n).text), - textToStr(module(source).text), - textToStr(module(name(clash).mod).text) - EEND; - } -} - -static Void local importTycon(source,tc) -Module source; -Tycon tc; { - Tycon clash=addTycon(tc); - if (nonNull(clash) && clash!=tc) { - ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"", - textToStr(tycon(tc).text), - textToStr(module(source).text), - textToStr(module(tycon(clash).mod).text) - EEND; - } - if (nonNull(findClass(tycon(tc).text))) { - ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"", - textToStr(tycon(tc).text), - textToStr(module(tycon(tc).mod).text) - EEND; - } -} - -static Void local importClass(source,c) -Module source; -Class c; { - Class clash=addClass(c); - if (nonNull(clash) && clash!=c) { - ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"", - textToStr(cclass(c).text), - textToStr(module(source).text), - textToStr(module(cclass(clash).mod).text) - EEND; - } - if (nonNull(findTycon(cclass(c).text))) { - ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"", - textToStr(cclass(c).text), - textToStr(module(source).text) - EEND; - } -} - -static List local checkExportTycon(exports,mt,spec,tc) -List exports; -Text mt; -Cell spec; -Tycon tc; { - if (DOTDOT == spec || SYNONYM == tycon(tc).what) { - return cons(pair(tc,DOTDOT), exports); - } else { - return cons(pair(tc,NIL), exports); - } -} - -static List local checkExportClass(exports,mt,spec,cl) -List exports; -Text mt; -Class cl; -Cell spec; { - if (DOTDOT == spec) { - return cons(pair(cl,DOTDOT), exports); - } else { - return cons(pair(cl,NIL), exports); - } -} - -static List local checkExport(exports,mt,e) /* Process entry in export list*/ -List exports; -Text mt; -Cell e; { - if (isIdent(e)) { - Cell export = NIL; - List origExports = exports; - if (nonNull(export=findQualName(0,e))) { - exports=cons(export,exports); - } - if (isQCon(e) && nonNull(export=findQualTycon(e))) { - exports = checkExportTycon(exports,mt,NIL,export); - } - if (isQCon(e) && nonNull(export=findQualClass(e))) { - /* opaque class export */ - exports = checkExportClass(exports,mt,NIL,export); - } - if (exports == origExports) { - ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"", - identToStr(e), - textToStr(mt) - EEND; - } - return exports; - } else if (MODULEENT == fst(e)) { - Module m = findModid(snd(e)); - /* ToDo: shouldn't allow export of module we didn't import */ - if (isNull(m)) { - ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"", - textToStr(textOf(snd(e))), - textToStr(mt) - EEND; - } - if (m == currentModule) { - /* Exporting the current module exports local definitions */ - List xs; - for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) { - if (cclass(hd(xs)).mod==m) - exports = checkExportClass(exports,mt,DOTDOT,hd(xs)); - } - for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) { - if (tycon(hd(xs)).mod==m) - exports = checkExportTycon(exports,mt,DOTDOT,hd(xs)); - } - for(xs=module(m).names; nonNull(xs); xs=tl(xs)) { - if (name(hd(xs)).mod==m) - exports = cons(hd(xs),exports); - } - } else { - /* Exporting other modules imports all things imported - * unqualified from it. - * ToDo: we reexport everything exported by a module - - * whether we imported it or not. This gives the wrong - * result for "module M(module N) where import N(x)" - */ - exports = revDupOnto(module(m).exports,exports); - } - return exports; - } else { - Cell ident = fst(e); /* class name or type name */ - Cell parts = snd(e); /* members or constructors */ - Cell nm; - if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) { - switch (tycon(nm).what) { - case SYNONYM: - if (DOTDOT!=parts) { - ERRMSG(0) "Explicit constructor list given for type synonym \"%s\" in export list of module \"%s\"", - identToStr(ident), - textToStr(mt) - EEND; - } - return cons(pair(nm,DOTDOT),exports); - case RESTRICTSYN: - ERRMSG(0) "Transparent export of restricted type synonym \"%s\" in export list of module \"%s\"", - identToStr(ident), - textToStr(mt) - EEND; - return exports; /* Not reached */ - case NEWTYPE: - case DATATYPE: - if (DOTDOT==parts) { - return cons(pair(nm,DOTDOT),exports); - } else { - exports = checkSubentities(exports,parts,tycon(nm).defn, - "constructor of type", - tycon(nm).text); - return cons(pair(nm,DOTDOT), exports); - } - default: - internal("checkExport1"); - } - } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) { - if (DOTDOT == parts) { - return cons(pair(nm,DOTDOT),exports); - } else { - exports = checkSubentities(exports,parts,cclass(nm).members, - "member of class",cclass(nm).text); - return cons(pair(nm,DOTDOT), exports); - } - } else { - ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"", - identToStr(ident), - textToStr(mt) - EEND; - } - } -} - -List checkExports(thisModule,exports) -Module thisModule; -List exports; { - Text mt = module(thisModule).text; - List es = NIL; - - map1Accum(checkExport,es,mt,exports); - -#if DEBUG_MODULES - for(xs=es; nonNull(xs); xs=tl(xs)) { - printf(" %s", textToStr(textOfEntity(hd(xs)))); - } -#endif - return es; -} - -/*-------------------------------------------------------------------------*/ - diff --git a/ghc/interpreter/modules.h b/ghc/interpreter/modules.h deleted file mode 100644 index 82ef338..0000000 --- a/ghc/interpreter/modules.h +++ /dev/null @@ -1,9 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -Void checkQualImport Args((Pair)); -Void checkUnqualImport Args((Triple)); -Void checkImportList Args((Module,Pair)); -List checkExports Args((Module,List)); - -Void importEntity Args((Module,Cell)); - - diff --git a/ghc/interpreter/optimise.h b/ghc/interpreter/optimise.h deleted file mode 100644 index 70cbd76..0000000 --- a/ghc/interpreter/optimise.h +++ /dev/null @@ -1,2 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -extern Void optimiseBind Args((StgVar)); diff --git a/ghc/interpreter/output.h b/ghc/interpreter/output.h deleted file mode 100644 index 838b23b..0000000 --- a/ghc/interpreter/output.h +++ /dev/null @@ -1,7 +0,0 @@ -extern Void printExp Args((FILE *,Cell)); -extern Void printType Args((FILE *,Cell)); -extern Void printContext Args((FILE *,List)); -extern Void printPred Args((FILE *,Cell)); -extern Void printKind Args((FILE *,Kind)); -extern Void printKinds Args((FILE *,Kinds)); - diff --git a/ghc/interpreter/pat.c b/ghc/interpreter/pat.c deleted file mode 100644 index bcd7a93..0000000 --- a/ghc/interpreter/pat.c +++ /dev/null @@ -1,409 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * Desugarer - * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 - * - * $RCSfile: pat.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:22:28 $ - * ------------------------------------------------------------------------*/ - -#include "prelude.h" -#include "storage.h" -#include "connect.h" -#include "errors.h" -#include "link.h" - -#include "pat.h" -#include "desugar.h" - -/* -------------------------------------------------------------------------- - * Local function prototypes: - * ------------------------------------------------------------------------*/ - -static Cell local refutePat Args((Cell)); -static Cell local refutePatAp Args((Cell)); -static Cell local matchPat Args((Cell)); -static List local remPat1 Args((Cell,Cell,List)); - -/* -------------------------------------------------------------------------- - * Elimination of pattern bindings: - * - * The following code adopts the definition of failure free patterns as given - * in the Haskell 1.3 report; the term "irrefutable" is also used there for - * a subset of the failure free patterns described here, but has no useful - * role in this implementation. Basically speaking, the failure free patterns - * are: variable, wildcard, ~apat - * var@apat, if apat is failure free - * C apat1 ... apatn if C is a product constructor - * (i.e. an only constructor) and - * apat1,...,apatn are failure free - * Note that the last case automatically covers the case where C comes from - * a newtype construction. - * ------------------------------------------------------------------------*/ - -Bool failFree(pat) /* is pattern failure free? (do we need */ -Cell pat; { /* a conformality check?) */ - Cell c = getHead(pat); - - switch (whatIs(c)) { - case ASPAT : return failFree(snd(snd(pat))); - - case NAME : if (!isCfun(c) || cfunOf(c)!=0) - return FALSE; - /*intentional fall-thru*/ - case TUPLE : for (; isAp(pat); pat=fun(pat)) - if (!failFree(arg(pat))) - return FALSE; - /*intentional fall-thru*/ - case LAZYPAT : - case VAROPCELL : - case VARIDCELL : - case DICTVAR : - case WILDCARD : return TRUE; - -#if TREX - case EXT : return failFree(extField(pat)) && - failFree(extRow(pat)); -#endif - - case CONFLDS : if (cfunOf(fst(snd(c)))==0) { - List fs = snd(snd(c)); - for (; nonNull(fs); fs=tl(fs)) - if (!failFree(snd(hd(fs)))) - return FALSE; - return TRUE; - } - /*intentional fall-thru*/ - default : return FALSE; - } -} - -static Cell local refutePat(pat) /* find pattern to refute in conformality*/ -Cell pat; { /* test with pat. */ - /* e.g. refPat (x:y) == (_:_) */ - /* refPat ~(x:y) == _ etc.. */ - - switch (whatIs(pat)) { - case ASPAT : return refutePat(snd(snd(pat))); - - case FINLIST : { Cell ys = snd(pat); - Cell xs = NIL; - for (; nonNull(ys); ys=tl(ys)) { - xs = ap2(nameCons,refutePat(hd(ys)),xs); - } - return revOnto(xs,nameNil); - } - - case CONFLDS : { Cell ps = NIL; - Cell fs = snd(snd(pat)); - for (; nonNull(fs); fs=tl(fs)) { - Cell p = refutePat(snd(hd(fs))); - ps = cons(pair(fst(hd(fs)),p),ps); - } - return pair(CONFLDS,pair(fst(snd(pat)),rev(ps))); - } - - case VAROPCELL : - case VARIDCELL : - case DICTVAR : - case WILDCARD : - case LAZYPAT : return WILDCARD; - - case STRCELL : - case CHARCELL : -#if NPLUSK - case ADDPAT : -#endif - case TUPLE : - case NAME : return pat; - - case AP : return refutePatAp(pat); - - default : internal("refutePat"); - return NIL; /*NOTREACHED*/ - } -} - -static Cell local refutePatAp(p) /* find pattern to refute in conformality*/ -Cell p; { - Cell h = getHead(p); - if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble) - return p; -#if NPLUSK - else if (whatIs(h)==ADDPAT) - return ap(fun(p),refutePat(arg(p))); -#endif -#if TREX - else if (isExt(h)) { - Cell pf = refutePat(extField(p)); - Cell pr = refutePat(extRow(p)); - return ap2(fun(fun(p)),pf,pr); - } -#endif - else { - List as = getArgs(p); - mapOver(refutePat,as); - return applyToArgs(h,as); - } -} - -static Cell local matchPat(pat) /* find pattern to match against */ -Cell pat; { /* replaces parts of pattern that do not */ - /* include variables with wildcards */ - switch (whatIs(pat)) { - case ASPAT : { Cell p = matchPat(snd(snd(pat))); - return (p==WILDCARD) ? fst(snd(pat)) - : ap(ASPAT, - pair(fst(snd(pat)),p)); - } - - case FINLIST : { Cell ys = snd(pat); - Cell xs = NIL; - for (; nonNull(ys); ys=tl(ys)) - xs = cons(matchPat(hd(ys)),xs); - while (nonNull(xs) && hd(xs)==WILDCARD) - xs = tl(xs); - for (ys=nameNil; nonNull(xs); xs=tl(xs)) - ys = ap2(nameCons,hd(xs),ys); - return ys; - } - - case CONFLDS : { Cell ps = NIL; - Name c = fst(snd(pat)); - Cell fs = snd(snd(pat)); - Bool avar = FALSE; - for (; nonNull(fs); fs=tl(fs)) { - Cell p = matchPat(snd(hd(fs))); - ps = cons(pair(fst(hd(fs)),p),ps); - if (p!=WILDCARD) - avar = TRUE; - } - return avar ? pair(CONFLDS,pair(c,rev(ps))) - : WILDCARD; - } - - case VAROPCELL : - case VARIDCELL : - case DICTVAR : return pat; - - case LAZYPAT : { Cell p = matchPat(snd(pat)); - return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p); - } - - case WILDCARD : - case STRCELL : - case CHARCELL : return WILDCARD; - - case TUPLE : - case NAME : - case AP : { Cell h = getHead(pat); - if (h==nameFromInt || - h==nameFromInteger || h==nameFromDouble) - return WILDCARD; -#if NPLUSK - else if (whatIs(h)==ADDPAT) - return pat; -#endif -#if TREX - else if (isExt(h)) { - Cell pf = matchPat(extField(pat)); - Cell pr = matchPat(extRow(pat)); - return (pf==WILDCARD && pr==WILDCARD) - ? WILDCARD - : ap2(fun(fun(pat)),pf,pr); - } -#endif - else { - List args = NIL; - Bool avar = FALSE; - for (; isAp(pat); pat=fun(pat)) { - Cell p = matchPat(arg(pat)); - if (p!=WILDCARD) - avar = TRUE; - args = cons(p,args); - } - return avar ? applyToArgs(pat,args) - : WILDCARD; - } - } - - default : internal("matchPat"); - return NIL; /*NOTREACHED*/ - } -} - -#define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds) - -List remPat(pat,expr,lds) -Cell pat; /* Produce list of definitions for eqn */ -Cell expr; /* pat = expr, including a conformality */ -List lds; { /* check if required. */ - - /* Conformality test (if required): - * pat = expr ==> nv = LETREC confCheck nv@pat = nv - * IN confCheck expr - * remPat1(pat,nv,.....); - */ - - if (!failFree(pat)) { - Cell confVar = inventVar(); - Cell nv = inventVar(); - Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */ - singleton(pair(singleton(ap(ASPAT, - pair(nv, - refutePat(pat)))), - nv))); - - if (whatIs(expr)==GUARDED) { /* A spanner ... special case */ - lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/ - expr = nv; - nv = inventVar(); - } - - if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/ - nv = fst(snd(pat)); /* a variable is already given*/ - pat = snd(snd(pat)); /* by an as-pattern */ - } - - lds = addEqn(nv, /* nv = */ - ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */ - ap(confVar,expr))), /* IN confVar expr */ - lds); - - return remPat1(matchPat(pat),nv,lds); - } - - return remPat1(matchPat(pat),expr,lds); -} - -static List local remPat1(pat,expr,lds) -Cell pat; /* Add definitions for: pat = expr to */ -Cell expr; /* list of local definitions in lds. */ -List lds; { - Cell c; - - switch (whatIs(c=getHead(pat))) { - case WILDCARD : - case STRCELL : - case CHARCELL : break; - - case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */ - fst(snd(pat)), - addEqn(fst(snd(pat)),expr,lds)); - - case LAZYPAT : { Cell nv; - - if (isVar(expr) || isName(expr)) - nv = expr; - else { - nv = inventVar(); - lds = addEqn(nv,expr,lds); - } - - return remPat(snd(pat),nv,lds); - } - -#if NPLUSK - case ADDPAT : return remPat1(arg(pat), /* n + k = expr */ - ap3(namePmSub, arg(fun(pat)), snd(c), - expr), - lds); -#endif - - case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds); - - case CONFLDS : { Name h = fst(snd(pat)); - Int m = name(h).arity; - Cell p = h; - List fs = snd(snd(pat)); - Int i = m; - while (00; i--) - r = fun(r); - arg(r) = snd(hd(fs)); - } - return remPat1(p,expr,lds); - } - - case DICTVAR : /* shouldn't really occur */ - assert(0); /* so let's test for it then! ADR */ - case VARIDCELL : - case VAROPCELL : return addEqn(pat,expr,lds); - - case NAME : if (c==nameFromInt || c==nameFromInteger - || c==nameFromDouble) { - if (argCount==2) - arg(fun(pat)) = translate(arg(fun(pat))); - break; - } - - if (argCount==1 && isCfun(c) /* for newtype */ - && cfunOf(c)==0 && name(c).defn==nameId) - return remPat1(arg(pat),expr,lds); - - /* intentional fall-thru */ - case TUPLE : { List ps = getArgs(pat); - - if (nonNull(ps)) { - Cell nv, sel; - Int i; - - if (isVar(expr) || isName(expr)) - nv = expr; - else { - nv = inventVar(); - lds = addEqn(nv,expr,lds); - } - - sel = ap2(nameSel,c,nv); - for (i=1; nonNull(ps); ++i, ps=tl(ps)) - lds = remPat1(hd(ps), - ap(sel,mkInt(i)), - lds); - } - } - break; - -#if TREX - case EXT : { Cell nv = inventVar(); - arg(fun(fun(pat))) - = translate(arg(fun(fun(pat)))); - lds = addEqn(nv, - ap2(nameRecBrk, - arg(fun(fun(pat))), - expr), - lds); - lds = remPat1(extField(pat),ap(nameFst,nv),lds); - lds = remPat1(extRow(pat),ap(nameSnd,nv),lds); - } - break; -#endif - - default : internal("remPat1"); - break; - } - return lds; -} - -/* -------------------------------------------------------------------------- - * Pattern control: - * ------------------------------------------------------------------------*/ - -Void patControl( Int what ) -{ - switch (what) { - case INSTALL : - /* Fall through */ - case RESET : break; - case MARK : break; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/pat.h b/ghc/interpreter/pat.h deleted file mode 100644 index 7844b70..0000000 --- a/ghc/interpreter/pat.h +++ /dev/null @@ -1,5 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -extern Void patControl Args((Int what)); -extern List remPat Args((Cell,Cell,List)); -extern Cell mkConsList Args((List)); -extern Bool failFree Args((Cell)); diff --git a/ghc/interpreter/pmc.c b/ghc/interpreter/pmc.c deleted file mode 100644 index b6a2bd4..0000000 --- a/ghc/interpreter/pmc.c +++ /dev/null @@ -1,585 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * Pattern matching Compiler - * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 - * - * $RCSfile: pmc.c,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:22:29 $ - * ------------------------------------------------------------------------*/ - -#include "prelude.h" -#include "storage.h" -#include "connect.h" -#include "errors.h" -#include "link.h" - -#include "desugar.h" -#include "pat.h" -#include "pmc.h" - -/* -------------------------------------------------------------------------- - * Eliminate pattern matching in function definitions -- pattern matching - * compiler: - * - * The original Gofer/Hugs pattern matching compiler was based on Wadler's - * algorithms described in `Implementation of functional programming - * languages'. That should still provide a good starting point for anyone - * wanting to understand this part of the system. However, the original - * algorithm has been generalized and restructured in order to implement - * new features added in Haskell 1.3. - * - * During the translation, in preparation for later stages of compilation, - * all local and bound variables are replaced by suitable offsets, and - * locally defined function symbols are given new names (which will - * eventually be their names when lifted to make top level definitions). - * ------------------------------------------------------------------------*/ - -/* -------------------------------------------------------------------------- - * Local function prototypes: - * ------------------------------------------------------------------------*/ - -static Cell local pmcPair Args((Int,List,Pair)); -static Cell local pmcTriple Args((Int,List,Triple)); -static Cell local pmcVar Args((List,Text)); -static Void local pmcLetrec Args((Int,List,Pair)); -static Cell local pmcVarDef Args((Int,List,List)); -static Void local pmcFunDef Args((Int,List,Triple)); -static Cell local joinMas Args((Int,List)); -static Bool local canFail Args((Cell)); -static List local addConTable Args((Cell,Cell,List)); -static Void local advance Args((Int,Int,Cell)); -static Bool local emptyMatch Args((Cell)); -static Cell local maDiscr Args((Cell)); -static Bool local isNumDiscr Args((Cell)); -static Bool local eqNumDiscr Args((Cell,Cell)); -#if TREX -static Bool local isExtDiscr Args((Cell)); -static Bool local eqExtDiscr Args((Cell,Cell)); -#endif - -/* -------------------------------------------------------------------------- - * - * ------------------------------------------------------------------------*/ - -Cell pmcTerm(co,sc,e) /* apply pattern matching compiler */ -Int co; /* co = current offset */ -List sc; /* sc = scope */ -Cell e; { /* e = expr to transform */ - switch (whatIs(e)) { - case GUARDED : map2Over(pmcPair,co,sc,snd(e)); - break; - - case LETREC : pmcLetrec(co,sc,snd(e)); - break; - - case VARIDCELL: - case VAROPCELL: - case DICTVAR : return pmcVar(sc,textOf(e)); - - case COND : return ap(COND,pmcTriple(co,sc,snd(e))); - - case AP : return pmcPair(co,sc,e); - -#if NPLUSK - case ADDPAT : -#endif -#if TREX - case EXT : -#endif - case TUPLE : - case NAME : - case CHARCELL : - case INTCELL : - case BIGCELL : - case FLOATCELL: - case STRCELL : break; - - default : internal("pmcTerm"); - break; - } - return e; -} - -static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */ -Int co; /* to a pair of exprs */ -List sc; -Pair pr; { - return pair(pmcTerm(co,sc,fst(pr)), - pmcTerm(co,sc,snd(pr))); -} - -static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */ -Int co; /* to a triple of exprs */ -List sc; -Triple tr; { - return triple(pmcTerm(co,sc,fst3(tr)), - pmcTerm(co,sc,snd3(tr)), - pmcTerm(co,sc,thd3(tr))); -} - -static Cell local pmcVar(sc,t) /* find translation of variable */ -List sc; /* in current scope */ -Text t; { - List xs; - Name n; - - for (xs=sc; nonNull(xs); xs=tl(xs)) { - Cell x = hd(xs); - if (t==textOf(fst(x))) - if (isOffset(snd(x))) { /* local variable ... */ - return snd(x); - } - else { /* local function ... */ - return fst3(snd(x)); - } - } - - n = findName(t); - assert(nonNull(n)); - return n; -} - -static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */ -Int co; /* to LETREC, splitting decls into */ -List sc; /* two sections */ -Pair e; { - List fs = NIL; /* local function definitions */ - List vs = NIL; /* local variable definitions */ - List ds; - - for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */ - Cell v = fst(hd(ds)); - Int arity = length(fst(hd(snd(hd(ds))))); - - if (arity==0) { /* Variable declaration */ - vs = cons(snd(hd(ds)),vs); - sc = cons(pair(v,mkOffset(++co)),sc); - } - else { /* Function declaration */ - fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs); - sc = cons(pair(v,hd(fs)),sc); - } - } - vs = rev(vs); /* Put declaration lists back in */ - fs = rev(fs); /* original order */ - fst(e) = pair(vs,fs); /* Store declaration lists */ - map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */ - map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */ - snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */ -} - -static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */ -Int co; /* to variable definition */ -List sc; -List vd; { /* vd :: [ ([], rhs) ] */ - Cell d = snd(hd(vd)); - if (nonNull(tl(vd)) && canFail(d)) - return ap(FATBAR,pair(pmcTerm(co,sc,d), - pmcVarDef(co,sc,tl(vd)))); - return pmcTerm(co,sc,d); -} - -static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */ -Int co; /* to function definition */ -List sc; -Triple fd; { /* fd :: (Var, Arity, [Alt]) */ - Int arity = intOf(snd3(fd)); - Cell temp = altsMatch(co+1,arity,sc,thd3(fd)); - Cell xs; - - temp = match(co+arity,temp); - thd3(fd) = triple(NIL,NIL,temp); /* used to be freevar info */ - -} - -/* --------------------------------------------------------------------------- - * Main part of pattern matching compiler: convert [Alt] to case constructs - * - * This section of Hugs has been almost completely rewritten to be more - * general, in particular, to allow pattern matching in orders other than the - * strictly left-to-right approach of the previous version. This is needed - * for the implementation of the so-called Haskell 1.3 `record' syntax. - * - * At each stage, the different branches for the cases to be considered - * are represented by a list of values of type: - * Match ::= { maPats :: [Pat], patterns to match - * maOffs :: [Offs], offsets of corresponding values - * maSc :: Scope, mapping from vars to offsets - * maRhs :: Rhs } right hand side - * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).] - * - * The Scope component has type: - * Scope ::= [(Var,Expr)] - * and provides a mapping from variable names to offsets used in the matching - * process. - * - * Matches can be normalized by reducing them to a form in which the list - * of patterns is empty (in which case the match itself is described as an - * empty match), or in which the list is non-empty and the first pattern is - * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose. - * ------------------------------------------------------------------------*/ - -#define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r)) -#define maPats(ma) fst(fst(ma)) -#define maOffs(ma) snd(fst(ma)) -#define maSc(ma) fst(snd(ma)) -#define maRhs(ma) snd(snd(ma)) -#define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma)) - -List altsMatch(co,n,sc,as) /* Make a list of matches from list*/ -Int co; /* of Alts, with initial offsets */ -Int n; /* reverse (take n [co..]) */ -List sc; -List as; { - List mas = NIL; - List us = NIL; - for (; n>0; n--) - us = cons(mkOffset(co++),us); - for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */ - mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas); - return rev(mas); -} - -Cell match(co,mas) /* Generate case statement for Matches mas */ -Int co; /* at current offset co */ -List mas; { /* N.B. Assumes nonNull(mas). */ - Cell srhs = NIL; /* Rhs for selected matches */ - List smas = mas; /* List of selected matches */ - mas = tl(mas); - tl(smas) = NIL; - - if (emptyMatch(hd(smas))) { /* The case for empty matches: */ - while (nonNull(mas) && emptyMatch(hd(mas))) { - List temp = tl(mas); - tl(mas) = smas; - smas = mas; - mas = temp; - } - srhs = joinMas(co,rev(smas)); - } - else { /* Non-empty match */ - Int o = offsetOf(hd(maOffs(hd(smas)))); - Cell d = maDiscr(hd(smas)); - if (isNumDiscr(d)) { /* Numeric match */ - Int da = discrArity(d); - Cell d1 = pmcTerm(co,maSc(hd(smas)),d); - while (nonNull(mas) && !emptyMatch(hd(mas)) - && o==offsetOf(hd(maOffs(hd(mas)))) - && isNumDiscr(d=maDiscr(hd(mas))) - && eqNumDiscr(d,d1)) { - List temp = tl(mas); - tl(mas) = smas; - smas = mas; - mas = temp; - } - smas = rev(smas); - map2Proc(advance,co,da,smas); - srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas))); - } -#if TREX - else if (isExtDiscr(d)) { /* Record match */ - Int da = discrArity(d); - Cell d1 = pmcTerm(co,maSc(hd(smas)),d); - while (nonNull(mas) && !emptyMatch(hd(mas)) - && o==offsetOf(hd(maOffs(hd(mas)))) - && isExtDiscr(d=maDiscr(hd(mas))) - && eqExtDiscr(d,d1)) { - List temp = tl(mas); - tl(mas) = smas; - smas = mas; - mas = temp; - } - smas = rev(smas); - map2Proc(advance,co,da,smas); - srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas))); - } -#endif - else { /* Constructor match */ - List tab = addConTable(d,hd(smas),NIL); - Int da; - while (nonNull(mas) && !emptyMatch(hd(mas)) - && o==offsetOf(hd(maOffs(hd(mas)))) - && !isNumDiscr(d=maDiscr(hd(mas)))) { - tab = addConTable(d,hd(mas),tab); - mas = tl(mas); - } - for (tab=rev(tab); nonNull(tab); tab=tl(tab)) { - d = fst(hd(tab)); - smas = snd(hd(tab)); - da = discrArity(d); - map2Proc(advance,co,da,smas); - srhs = cons(pair(d,match(co+da,smas)),srhs); - } - srhs = ap(CASE,pair(mkOffset(o),srhs)); - } - } - return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs; -} - -static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/ -Int co; /* using FATBARs as necessary */ -List mas; { /* Non-empty list of empty matches */ - Cell ma = hd(mas); - Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma)); - if (nonNull(tl(mas)) && canFail(rhs)) - return ap(FATBAR,pair(rhs,joinMas(co,tl(mas)))); - else - return rhs; -} - -static Bool local canFail(rhs) /* Determine if expression (as rhs) */ -Cell rhs; { /* might ever be able to fail */ - switch (whatIs(rhs)) { - case LETREC : return canFail(snd(snd(rhs))); - case GUARDED : return TRUE; /* could get more sophisticated ..? */ - default : return FALSE; - } -} - -/* type Table a b = [(a, [b])] - * - * addTable :: a -> b -> Table a b -> Table a b - * addTable x y [] = [(x,[y])] - * addTable x y (z@(n,sws):zs) - * | n == x = (n,sws++[y]):zs - * | otherwise = (n,sws):addTable x y zs - */ - -static List local addConTable(x,y,tab) /* add element (x,y) to table */ -Cell x, y; -List tab; { - if (isNull(tab)) - return singleton(pair(x,singleton(y))); - else if (fst(hd(tab))==x) - snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y)); - else - tl(tab) = addConTable(x,y,tl(tab)); - - return tab; -} - -static Void local advance(co,a,ma) /* Advance non-empty match by */ -Int co; /* processing head pattern */ -Int a; /* discriminator arity */ -Cell ma; { - Cell p = hd(maPats(ma)); - List ps = tl(maPats(ma)); - List us = tl(maOffs(ma)); - if (whatIs(p)==CONFLDS) { /* Special case for record syntax */ - Name c = fst(snd(p)); - List fs = snd(snd(p)); - List qs = NIL; - List vs = NIL; - for (; nonNull(fs); fs=tl(fs)) { - vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs); - qs = cons(snd(hd(fs)),qs); - } - ps = revOnto(qs,ps); - us = revOnto(vs,us); - } - else /* Normally just spool off patterns*/ - for (; a>0; --a) { /* and corresponding offsets ... */ - us = cons(mkOffset(++co),us); - ps = cons(arg(p),ps); - p = fun(p); - } - - maPats(ma) = ps; - maOffs(ma) = us; -} - -/* -------------------------------------------------------------------------- - * Normalize and test for empty match: - * ------------------------------------------------------------------------*/ - -static Bool local emptyMatch(ma)/* Normalize and test to see if a given */ -Cell ma; { /* match, ma, is empty. */ - - while (nonNull(maPats(ma))) { - Cell p; -tidyHd: switch (whatIs(p=hd(maPats(ma)))) { - case LAZYPAT : { Cell nv = inventVar(); - maRhs(ma) = ap(LETREC, - pair(remPat(snd(p),nv,NIL), - maRhs(ma))); - p = nv; - } - /* intentional fall-thru */ - case VARIDCELL : - case VAROPCELL : - case DICTVAR : extSc(p,hd(maOffs(ma)),ma); - case WILDCARD : maPats(ma) = tl(maPats(ma)); - maOffs(ma) = tl(maOffs(ma)); - continue; - - /* So-called "as-patterns"are really just pattern intersections: - * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e) - * (But the input grammar probably doesn't let us take - * advantage of this, so we stick with the special case - * when p1 is a variable.) - */ - case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma); - hd(maPats(ma)) = snd(snd(p)); - goto tidyHd; - - case FINLIST : hd(maPats(ma)) = mkConsList(snd(p)); - return FALSE; - - case STRCELL : { String s = textToStr(textOf(p)); - for (p=NIL; *s!='\0'; ++s) { - if (*s!='\\' || *++s=='\\') { - p = ap2(nameCons,mkChar(*s),p); - } else { - p = ap2(nameCons,mkChar('\0'),p); - } - } - hd(maPats(ma)) = revOnto(p,nameNil); - } - return FALSE; - - case AP : if (isName(fun(p)) && isCfun(fun(p)) - && cfunOf(fun(p))==0 - && name(fun(p)).defn==nameId) { - hd(maPats(ma)) = arg(p); - goto tidyHd; - } - /* intentional fall-thru */ - case CHARCELL : -#if !OVERLOADED_CONSTANTS - case INTCELL : - case BIGCELL : - case FLOATCELL : -#endif - case NAME : - case CONFLDS : - return FALSE; - - default : internal("emptyMatch"); - } - } - return TRUE; -} - -/* -------------------------------------------------------------------------- - * Discriminators: - * ------------------------------------------------------------------------*/ - -static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */ -Cell ma; { /* match, ma. */ - Cell p = hd(maPats(ma)); - Cell h = getHead(p); - switch (whatIs(h)) { - case CONFLDS : return fst(snd(p)); -#if NPLUSK - case ADDPAT : arg(fun(p)) = translate(arg(fun(p))); - return fun(p); -#endif -#if TREX - case EXT : h = fun(fun(p)); - arg(h) = translate(arg(h)); - return h; -#endif -#if OVERLOADED_CONSTANTS - case NAME : if (h==nameFromInt || h==nameFromInteger - || h==nameFromDouble) { - if (argCount==2) - arg(fun(p)) = translate(arg(fun(p))); - return p; - } -#endif - } - return h; -} - -static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */ -Cell d; { - switch (whatIs(d)) { - case NAME : - case TUPLE : - case CHARCELL : return FALSE; -#if OVERLOADED_CONSTANTS -#if TREX - case AP : return !isExt(fun(d)); -#else - case AP : return TRUE; /* must be a literal or (n+k) */ -#endif -#else - case INTCELL : - case BIGCELL : - case FLOATCELL: - return TRUE; -#endif - } - internal("isNumDiscr"); - return 0;/*NOTREACHED*/ -} - -Int discrArity(d) /* Find arity of discriminator */ -Cell d; { - switch (whatIs(d)) { - case NAME : return name(d).arity; - case TUPLE : return tupleOf(d); - case CHARCELL : return 0; -#if !OVERLOADED_CONSTANTS - case INTCELL : - case BIGCELL : - case FLOATCELL : return 0; -#endif /* !OVERLOADED_CONSTANTS */ - -#if TREX - case AP : switch (whatIs(fun(d))) { -#if NPLUSK - case ADDPAT : return 1; -#endif - case EXT : return 2; - default : return 0; - } -#else -#if NPLUSK - case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0; -#else - case AP : return 0; /* must be an Int or Float lit */ -#endif -#endif - } - internal("discrArity"); - return 0;/*NOTREACHED*/ -} - -static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */ -Cell d1, d2; { /* descriptors have same value */ -#if NPLUSK - if (whatIs(fun(d1))==ADDPAT) - return whatIs(fun(d2))==ADDPAT && bignumEq(snd(fun(d1)),snd(fun(d2))); -#endif -#if OVERLOADED_CONSTANTS - d1 = arg(d1); - d2 = arg(d2); -#endif - if (isInt(d1)) - return isInt(d2) && intEq(d1,d2); - if (isFloat(d1)) - return isFloat(d2) && floatEq(d1,d2); - if (isBignum(d1)) - return isBignum(d2) && bignumEq(d1,d2); - internal("eqNumDiscr"); - return FALSE;/*NOTREACHED*/ -} - -#if TREX -static Bool local isExtDiscr(d) /* Test of extension discriminator */ -Cell d; { - return isAp(d) && isExt(fun(d)); -} - -static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */ -Cell d1, d2; { /* discriminators have same label */ - return fun(d1)==fun(d2); -} -#endif - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/pmc.h b/ghc/interpreter/pmc.h deleted file mode 100644 index 391493d..0000000 --- a/ghc/interpreter/pmc.h +++ /dev/null @@ -1,6 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -extern Cell pmcTerm Args((Int,List,Cell)); -extern List altsMatch Args((Int,Int,List,List)); -extern Cell match Args((Int,List)); -extern Int discrArity Args((Cell)); - diff --git a/ghc/interpreter/pp.h b/ghc/interpreter/pp.h deleted file mode 100644 index e06f893..0000000 --- a/ghc/interpreter/pp.h +++ /dev/null @@ -1,16 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * Pretty printer for stg code: - * ------------------------------------------------------------------------*/ - -Void printStg( FILE *fp, StgVar b); - -#if DEBUG_PRINTER -extern Void ppStg ( StgVar v ); -extern Void ppStgExpr ( StgExpr e ); -extern Void ppStgRhs ( StgRhs rhs ); -extern Void ppStgAlts ( List alts ); -extern Void ppStgPrimAlts( List alts ); -extern Void ppStgVars ( List vs ); -#endif - diff --git a/ghc/interpreter/static.h b/ghc/interpreter/static.h deleted file mode 100644 index 4b89283..0000000 --- a/ghc/interpreter/static.h +++ /dev/null @@ -1,30 +0,0 @@ -extern List unqualImports; /* unqualified import list */ - -#if DERIVE_SHOW | DERIVE_READ -extern List cfunSfuns; -#endif -extern Void startModule Args((Cell)); -extern Void setExportList Args((List)); -extern Void setExports Args((List)); -extern Void addQualImport Args((Text,Text)); -extern Void addUnqualImport Args((Text,List)); -extern Void tyconDefn Args((Int,Cell,Cell,Cell)); -extern Void setTypeIns Args((List)); -extern Void clearTypeIns Args((Void)); -extern Type fullExpand Args((Type)); -extern Bool isAmbiguous Args((Type)); -extern Void ambigError Args((Int,String,Cell,Type)); -extern Void classDefn Args((Int,Cell,Cell)); -extern Void instDefn Args((Int,Cell,Cell)); -extern Void addTupInst Args((Class,Int)); -#if TREX -extern Inst addRecShowInst Args((Class,Ext)); -extern Inst addRecEqInst Args((Class,Ext)); -#endif -extern Void addEvalInst Args((Int,Cell,Int,List)); -extern Void foreignImport Args((Cell,Pair,Cell,Cell)); -extern Void foreignExport Args((Cell,Cell,Cell,Cell)); -extern Void defaultDefn Args((Int,List)); -extern Void checkExp Args((Void)); -extern Void checkDefns Args((Void)); - diff --git a/ghc/interpreter/stg.h b/ghc/interpreter/stg.h deleted file mode 100644 index 5a04230..0000000 --- a/ghc/interpreter/stg.h +++ /dev/null @@ -1,141 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -/* -------------------------------------------------------------------------- - * STG syntax - * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 - * - * $RCSfile: stg.h,v $ - * $Revision: 1.2 $ - * $Date: 1998/12/02 13:22:39 $ - * ------------------------------------------------------------------------*/ - -/* -------------------------------------------------------------------------- - * STG Syntax: - * - * Rhs -> STGCON (Con, [Atom]) - * | STGAPP (Var, [Atom]) -- delayed application - * | Expr - * - * Expr -> LETREC ([Var],Expr) -- Vars contain their bound value - * | LAMBDA ([Var],Expr) -- all vars bound to NIL - * | CASE (Expr,[Alt]) - * | PRIMCASE (Expr,[PrimAlt]) - * | STGPRIM (Prim,[Atom]) - * | STGAPP (Var, [Atom]) -- tail call - * | Var -- Abbreviation for STGAPP(Var,[]) - * - * Atom -> Var - * | CHAR -- unboxed - * | INT -- unboxed - * | BIGNUM -- unboxed - * | FLOAT -- unboxed - * | ADDR -- unboxed - * | STRING -- boxed - * - * Var -> STGVAR (Rhs,StgRep,info) -- let, case or lambda bound - * | Name -- let-bound (effectively) - * -- always unboxed (PTR_REP) - * - * Alt -> (Pat,Expr) - * Pat -> Var -- bound to a constructor, a tuple or unbound - * PrimAlt -> ([PrimPat],Expr) - * PrimPat -> Var -- bound to int or unbound - * - * We use pointer equality to distinguish variables. - * The info field of a Var is used as follows in various phases: - * - * Translation: unused (set to NIL on output) - * Freevar analysis: list of free vars after - * Lambda lifting: freevar list or UNIT on input, discarded after - * Code generation: unused - * ------------------------------------------------------------------------*/ - -typedef Cell StgRhs; -typedef Cell StgExpr; -typedef Cell StgAtom; -typedef Cell StgVar; /* Could be a Name or an STGVAR */ -typedef Pair StgCaseAlt; -typedef StgVar StgPat; -typedef Cell StgDiscr; -typedef Pair StgPrimAlt; -typedef StgVar StgPrimPat; -typedef Cell StgRep; /* PTR_REP | .. DOUBLE_REP */ - -#define mkStgLet(binds,body) ap(LETREC,pair(binds,body)) -#define stgLetBinds(e) fst(snd(e)) -#define stgLetBody(e) snd(snd(e)) - -#define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info)) -#define stgVarBody(e) fst3(snd(e)) -#define stgVarRep(e) snd3(snd(e)) -#define stgVarInfo(e) thd3(snd(e)) - -#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts)) -#define stgCaseScrut(e) fst(snd(e)) -#define stgCaseAlts(e) snd(snd(e)) - -#define mkStgCaseAlt(discr,vs,e) pair(mkStgVar(mkStgCon(discr,vs),NIL),e) -#define stgCaseAltPat(alt) fst(alt) -#define stgCaseAltBody(alt) snd(alt) - -#define stgPatDiscr(pat) stgConCon(stgVarBody(pat)) -#define stgPatVars(pat) stgConArgs(stgVarBody(pat)) - -#define isDefaultPat(pat) (isNull(stgVarBody(pat))) -#define isStgDefault(alt) (isDefaultPat(stgCaseAltPat(alt))) -#define mkStgDefault(v,e) pair(v,e) - -#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts)) -#define stgPrimCaseScrut(e) fst(snd(e)) -#define stgPrimCaseAlts(e) snd(snd(e)) - -#define mkStgPrimAlt(vs,body) pair(vs,body) -#define stgPrimAltPats(alt) fst(alt) -#define stgPrimAltBody(alt) snd(alt) - -#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args)) -#define stgAppFun(e) fst(snd(e)) -#define stgAppArgs(e) snd(snd(e)) - -#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args)) -#define stgPrimOp(e) fst(snd(e)) -#define stgPrimArgs(e) snd(snd(e)) - -#define mkStgCon(con,args) ap(STGCON,pair(con,args)) -#define stgConCon(e) fst(snd(e)) -#define stgConArgs(e) snd(snd(e)) - -#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body)) -#define stgLambdaArgs(e) fst(snd(e)) -#define stgLambdaBody(e) snd(snd(e)) - -extern int stgConTag ( StgDiscr d ); -extern void* stgConInfo ( StgDiscr d ); -extern int stgDiscrTag( StgDiscr d ); - -/* -------------------------------------------------------------------------- - * Utility functions for manipulating STG syntax trees. - * ------------------------------------------------------------------------*/ - -extern List makeArgs ( Int ); -extern StgExpr makeStgLambda ( List args, StgExpr body ); -extern StgExpr makeStgApp ( StgVar fun, List args ); -extern StgExpr makeStgLet ( List binds, StgExpr body ); -extern StgExpr makeStgIf ( StgExpr cond, StgExpr e1, StgExpr e2 ); -extern Bool isStgVar ( StgRhs rhs ); -extern Bool isAtomic ( StgRhs rhs ); - -extern StgVar mkStgVar ( StgRhs rhs, Cell info ); - -#define mkSeq(x,y) mkStgCase(mkStgApp(nameForce,singleton(x)),singleton(mkStgDefault(mkStgVar(NIL,NIL),y))) - - -#define mkStgRep(c) mkChar(c) - -/*-------------------------------------------------------------------------*/ - - - - diff --git a/ghc/interpreter/stgSubst.h b/ghc/interpreter/stgSubst.h deleted file mode 100644 index 83a86cd..0000000 --- a/ghc/interpreter/stgSubst.h +++ /dev/null @@ -1,2 +0,0 @@ -/* -*- mode: hugs-c; -*- */ -extern StgExpr substExpr ( List sub, StgExpr e ); diff --git a/ghc/interpreter/translate.h b/ghc/interpreter/translate.h deleted file mode 100644 index e0684f2..0000000 --- a/ghc/interpreter/translate.h +++ /dev/null @@ -1,18 +0,0 @@ -extern Void stgDefn Args(( Name n, Int arity, Cell e )); - -extern Void implementForeignImport Args((Name)); -extern Void implementForeignExport Args((Name)); -extern Void implementCfun Args((Name, List)); -extern Void implementConToTag Args((Tycon)); -extern Void implementTagToCon Args((Tycon)); -extern Void implementPrim Args((Name)); -extern Void implementTuple Args((Int)); -#if TREX -extern Name implementRecShw Args((Text)); -extern Name implementRecEq Args((Text)); -#endif - -/* Association list storing globals assigned to dictionaries, tuples, etc */ -extern List stgGlobals; - - diff --git a/ghc/interpreter/type.h b/ghc/interpreter/type.h deleted file mode 100644 index 614bfa0..0000000 --- a/ghc/interpreter/type.h +++ /dev/null @@ -1,12 +0,0 @@ -extern Type typeCheckExp Args((Bool)); -extern Void typeCheckDefns Args((Void)); -extern Cell provePred Args((Kinds,List,Cell)); -extern List simpleContext Args((List,Int)); -extern Cell rhsExpr Args((Cell)); -extern Int rhsLine Args((Cell)); -extern List offsetTyvarsIn Args((Type,List)); -extern Type primType Args((Int/*AsmMonad*/,String,String)); -extern Type conToTagType Args((Tycon)); -extern Type tagToConType Args((Tycon)); -extern Void mkTypes Args((Void)); -